Datenstruktur ändern

Hallo Zusammen,
ich befasse mich gerade mit folgender Datei, wo bereits die folgende VBA hinterlegt ist.
Datei
https://www.dropbox.com/s/q1ssomc6gk55eys/Mappe4.xlsm?dl=0
VBA


Sub Schaltfläche1_Klicken()
Dim z, a, b, nam(7), zz, i, la, B1, B2, B3, B4
Columns("v:bz").Clear
For z = 2 To 1000
If Cells(z, 2)  "" Then
a = Val(Cells(z, 1)): b = Cells(z, 2)           'Titel 1
If a = 4 Then
la = 99
nam(2) = "": nam(3) = ""
For zz = z To 1 Step -1                     'Titel 2
la = a
a = Val(Cells(zz, 1)): b = Cells(zz, 2) 'Titel 3
If a > la Then Exit For
If nam(a) = "" Then nam(a) = b
nam(4) = Cells(z, 3)                    'Titel 4
B4 = Cells(z, 6)                        'Titel 4 Beschreibung
nam(5) = Cells(z, 2)                    'Aktiv?
nam(6) = Cells(z, 4)                    'Kategorie1
nam(7) = Cells(z, 5)                    'Kategorie2
If a = 1 Then Exit For
Next zz
i = i + 1
Cells(i + 1, 22) = nam(1)   'Titel 1
Cells(i + 1, 23) = B1       'Titel 1 Beschreibung
Cells(i + 1, 24) = nam(2)   'Titel 2
Cells(i + 1, 25) = B2       'Titel 2 Beschreibung
Cells(i + 1, 26) = nam(3)   'Titel 3
Cells(i + 1, 27) = B3       'Titel 3 Beschreibung
Cells(i + 1, 28) = nam(4)   'Titel 4
Cells(i + 1, 29) = B4       'Titel 4 Beschreibung
Cells(i + 1, 30) = nam(5)   'Aktiv
Cells(i + 1, 31) = nam(6)   'Kategorie1
Cells(i + 1, 32) = nam(7)   'Kategorie2
End If
End If
Next z
Application.ScreenUpdating = True
Sheets("tabelle5").Range("v1") = "Titel 1"
Sheets("tabelle5").Range("w1") = "Titel 1 Beschreibung"
Sheets("tabelle5").Range("x1") = "Titel 2"
Sheets("tabelle5").Range("y1") = "Titel 2 Beschreibung"
Sheets("tabelle5").Range("z1") = "Titel 3"
Sheets("tabelle5").Range("aa1") = "Titel 3 Beschreibung"
Sheets("tabelle5").Range("ab1") = "Titel 4"
Sheets("tabelle5").Range("ac1") = "Titel 4 Beschreibung"
Sheets("tabelle5").Range("ad1") = "Aktiv"
Sheets("tabelle5").Range("ae1") = "Kategorie1"
Sheets("tabelle5").Range("af1") = "Kategorie2"
End Sub

Mein Ziel ist es die SourceStruktur in hierarchischer Form in eine TargetStruktur in tabellarischer Form umzuwandeln. Die SourceStruktur besteht au 4 Leveln, bei der Level 1-3 jeweils einen Titel und eine Beschreibung haben. Level 4 hat weitere Detail Informationen.
Die TargetStruktur soll die folgenden Spalten erhalten
Titel1 / Titel1Beschreibung / Titel2 / Titel2Beschreibung / Titel3 / Titel3Beschreibung / Titel4 / Titel4Beschreibung / Titel4....Sonstige Spalten....
Die bereits vorhandene VBA setzt dies in Teilen bereits um, jedoch bekomme ich aktuell nur die Level1-3 Titel und nicht noch die zugehörigen Beschreibungen aus. Ideal wäre es wenn der Prozess zudem möglichst performant wäre für größere Datenmenge.
Vielen Dank im Voraus fürs Anschauen &
beste Grüße,
Jack

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Ergänzung: Zudem gibt das aktuelle VBA nur immer als Level1 Titel "A" aus, obwohl es mehrere Level 1 Titel gibt.
SourceStruktur
Level / Name
1 Main-Titel A
2 Sub-Titel AA
3 Sub-Sub-Titel AAA
4 Titel AAAA
4 Titel AAAB
4 Titel AAAC
2 Sub-Titel AB
4 Titel AB-A
4 Titel AB-B
4 Titel AB-C
1 Main-Titel B
4 Titel B--A
4 Titel B--B
4 Titel B--C
TargetStruktur
1 Main-Titel A 2 Sub-Titel AA 3 Sub-Sub-Titel AAA 4 Titel AAAA
1 Main-Titel A 2 Sub-Titel AA 3 Sub-Sub-Titel AAA 4 Titel AAAB
1 Main-Titel A 2 Sub-Titel AA 3 Sub-Sub-Titel AAA 4 Titel AAAC
1 Main-Titel A 2 Sub-Titel AB - 4 Titel AB-A
1 Main-Titel A 2 Sub-Titel AB - 4 Titel AB-B
1 Main-Titel A 2 Sub-Titel AB - 4 Titel AB-C
1 Main-Titel B - - 4 Titel B--A
1 Main-Titel B - - 4 Titel B--B
1 Main-Titel B - - 4 Titel B--C

Sub Schaltfläche1_Klicken() Dim arrDaten(), aZ As Long, larr As Long Dim Level1Titel As String, Level2Titel As String, Level3Titel As String Dim Level1Beschr As String, Level2Beschr As String, Level3Beschr As String Columns("V:AF").Clear larr = 0 ReDim arrDaten(10, larr) arrDaten(0, 0) = "Titel 1" arrDaten(1, 0) = "Titel 1 Beschreibung" arrDaten(2, 0) = "Titel 2" arrDaten(3, 0) = "Titel 2 Beschreibung" arrDaten(4, 0) = "Titel 3" arrDaten(5, 0) = "Titel 3 Beschreibung" arrDaten(6, 0) = "Titel 4" arrDaten(7, 0) = "Titel 4 Beschreibung" arrDaten(8, 0) = "Aktiv" arrDaten(9, 0) = "Kategorie1" arrDaten(10, 0) = "Kategorie2" For aZ = 2 To Range("A" & Rows.Count).End(xlUp).Row If Cells(aZ, 2) "" Then Select Case Cells(aZ, 1) Case 1 Level1Titel = Cells(aZ, 2) Level1Beschr = Cells(aZ, 4) Level2Titel = "" Level2Beschr = "" Level3Titel = "" Level3Beschr = "" Case 2 Level2Titel = Cells(aZ, 2) Level2Beschr = Cells(aZ, 4) Level3Titel = "" Level3Beschr = "" Case 3 Level3Titel = Cells(aZ, 2) Level3Beschr = Cells(aZ, 4) Case 4 larr = larr + 1 ReDim Preserve arrDaten(10, larr) arrDaten(0, larr) = Level1Titel 'Titel 1 arrDaten(1, larr) = Level1Beschr 'Titel 1 Beschreibung arrDaten(2, larr) = Level2Titel 'Titel 2 arrDaten(3, larr) = Level2Beschr 'Titel 2 Beschreibung arrDaten(4, larr) = Level3Titel 'Titel 3 arrDaten(5, larr) = Level3Beschr 'Titel 3 Beschreibung arrDaten(6, larr) = Cells(aZ, 3) 'Titel 4 arrDaten(7, larr) = Cells(aZ, 4) 'Titel 4 Beschreibung arrDaten(8, larr) = Cells(aZ, 2) 'Aktiv arrDaten(9, larr) = Cells(aZ, 5) 'Kategorie1 arrDaten(10, larr) = Cells(aZ, 6) 'Kategorie2 End Select End If Next Range("V1:AF" & larr + 1) = Application.WorksheetFunction.Transpose(arrDaten) End Sub

... Range("AG2").Resize(larr, 1).TextToColumns Destination:=Range("AG2"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 4), TrailingMinusNumbers:=True Range("AH2").Resize(larr, 1).TextToColumns Destination:=Range("AH2"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 4), TrailingMinusNumbers:=True End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread