AW: Tabellen per Makro generieren
07.04.2017 20:49:07
Dieter
Hallo Janiina,
ich war davon ausgegangen, dass die 3 Kategorien immer vorhanden sind.
Jetzt habe ich das Programm so ergänzt, dass die Anzahl der Kategorien beliebig sein kann.
Sub Generieren_V2()
Dim aktKat As String
Dim aktLO As ListObject ' aktuell zu bearbeitendes ListObjekt
Dim anfZeileLO As Long ' Anfangszeile des nächsten zu generierenden ListObjektes
Dim anfKat() As Long
Dim anzKat As Long ' Anzahl der vorhandenen Kategorien
Dim endKat() As Long
Dim j As Long
Dim k As Long
Dim Kat() As String
Dim listBereich As Range
Dim lo As ListObject
Dim loExistiert As Boolean
Dim loQuelle As ListObject
Dim jahr As Long
Dim spJahr As Long ' Jahresspalte
Dim stil(0 To 2) As String
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim zeile As Long
Dim zelle As Range
stil(0) = "TableStyleMedium9"
stil(1) = "TableStyleMedium4"
stil(2) = "TableStyleMedium7"
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
' Vorhandene ListObjekte löschen
For Each lo In ws2.ListObjects
lo.Delete
Next lo
ws2.UsedRange.ClearContents
Set loQuelle = ws1.ListObjects(1)
Set listBereich = loQuelle.DataBodyRange
' Anzahl der Kategorien bestimmen
For j = 1 To listBereich.Rows.Count
If listBereich.Columns(1).Cells(j) aktKat Then
anzKat = anzKat + 1
ReDim Preserve Kat(1 To anzKat)
ReDim Preserve anfKat(1 To anzKat)
ReDim Preserve endKat(1 To anzKat)
Kat(anzKat) = listBereich.Columns(1).Cells(j)
aktKat = listBereich.Columns(1).Cells(j)
anfKat(anzKat) = j
End If
Next j
For j = 1 To anzKat - 1
endKat(j) = anfKat(j + 1) - 1
Next j
endKat(anzKat) = listBereich.Rows.Count
anfZeileLO = 1
For spJahr = 3 To loQuelle.ListColumns.Count
jahr = loQuelle.HeaderRowRange.Cells(spJahr)
For k = 1 To anzKat
For zeile = anfKat(k) To endKat(k)
If listBereich.Cells(zeile, spJahr) = "X" Then
If loExistiert Then
' Dem vorhandenen ListObject aktLO eine weitere Zeile beifügen
aktLO.Resize Range:=ws2.Cells(anfZeileLO, "A").Resize(aktLO.ListRows.Count + 2, 7)
aktLO.DataBodyRange.Cells(aktLO.ListRows.Count, 1) = Kat(k)
aktLO.DataBodyRange.Cells(aktLO.ListRows.Count, 2) = listBereich.Cells(zeile, 2)
Else
' ListObject aktLO erzeugen und lfd. Element beifügen
ws2.Cells(anfZeileLO, "A") = jahr
ws2.Cells(anfZeileLO, "B") = "Name"
ws2.Cells(anfZeileLO, "C") = "Info"
For j = 2 To 5
ws2.Cells(anfZeileLO, j + 2) = "Info" & j
Next j
ws2.Cells(anfZeileLO + 1, "A") = Kat(k)
ws2.Cells(anfZeileLO + 1, "B") = listBereich.Cells(zeile, 2)
Set aktLO = ws2.ListObjects.Add(SourceType:=xlSrcRange, _
Source:=ws2.Cells(anfZeileLO, "A").Resize(2, 7), _
XlListObjectHasHeaders:=xlYes)
aktLO.TableStyle = stil((spJahr - 3) Mod 3)
loExistiert = True
End If
End If
Next zeile
If loExistiert Then
anfZeileLO = aktLO.Range.Row + aktLO.Range.Rows.Count + 1
End If
loExistiert = False
Next k
anfZeileLO = anfZeileLO + 1
Next spJahr
ws2.Activate
End Sub
Ich lade die Arbeitsmappe auch noch einmal hoch:
https://www.herber.de/bbs/user/112735.xlsm
Viele Grüße
Dieter