Datenliste reorganisieren

Sub ReorgData() Dim r As Long, lr As Long, nr As Long Dim T1 As String, T2 As String, T3 As String, B1 As String, B2 As String, B3 As String Application.ScreenUpdating = False lr = Cells(Rows.Count, 2).End(xlUp).Row Columns("v:as").Clear nr = 0 For r = 1 To lr Step 1 If Cells(r, 2) = "1" Then T1 = Cells(r, 3) B1 = Cells(r, 7) ElseIf Cells(r, 2) = "2" Then T2 = Cells(r, 3) B2 = Cells(r, 7) ElseIf Cells(r, 2) = "3" Then T3 = Cells(r, 3) B3 = Cells(r, 7) Else nr = nr + 1 Cells(nr, 22) = T1 Cells(nr, 23) = B1 Cells(nr, 24) = T2 Cells(nr, 25) = B2 Cells(nr, 26) = T3 Cells(nr, 27) = B3 Cells(nr, 28).Resize(, 28).Value = Cells(r, 1).Resize(, 28).Value End If Next r Application.ScreenUpdating = True Sheets("tabelle5").Range("v1") = "Titel1" Sheets("tabelle5").Range("w1") = "Titel1 Beschreibung" Sheets("tabelle5").Range("x1") = "Titel2" Sheets("tabelle5").Range("y1") = "Titel2 Beschreibung" Sheets("tabelle5").Range("z1") = "Titel3" Sheets("tabelle5").Range("aa1") = "Titel3 Beschreibung" Sheets("tabelle5").Range("ab1") = "Status" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo onur,
vielen Dank für die schnelle Antwort, das war sehr hilfreich!
Mir sind aber noch 2 Sachen aufgefallen
1) Das Skript kann nicht mit mehreren unterschiedlichen 1er Leveln umgehen. Aktuell schreibt er immer den ersten gefunden vorne weg, auch in deinem Beispiel
2) Was muss ich z.B. bei Level1 'a = Val(Cells(z, 1)): b = Cells(z, 2)' noch eingeben um parallel auf dem Level auch die zugehörische Beschreibung zu bekommen?
Im Anhang meine aktuelle Version. Wie gesagt, aktuell schreibt er immer den selben Wert für Level 1 rein, würde gerne pro Level die Beschreibung mit ausgeben und weitere Daten auf Level 4 mit ausgeben, hier Kategorie 1 und 4 (möglichst performant).
*QUELLE* (in Spalten)
Level Überschrift / Aktiv? Titel Kategorie1 Kategorie2
1 A
2 AA
3 AAA
4 Ja AAAA 1 1
4 Ja AAAB 2 2
4 Ja AAAC 3 3
2 AB
4 Ja AB-A 4 4
4 Ja AB-B 5 5
4 Ja AB-C 6 6
2 AC
4 Nein AC-A 7 7
4 Nein AC-B 8 8
2 AD
4 Ja AD-A 9 9
4 Ja AD-B 10 10
2 AE
4 Ja AE-A 11 11
4 Ja AE-B 12 12
2 AF
4 Nein AF-A 13 13
2 AG
4 Nein AG-A 14 14
2 AH
4 Ja AH-A 15 15
2 AI
4 Ja AI-A 16 16
4 Ja AI-B 17 17
2 AJ
4 Ja AJ-A 18 18
4 Ja AJ-B 19 19
2 AK
4 Ja AK-A 20 20
4 Ja AK-B 21 21
2 AL
4 Ja AL-A 22 22
4 Ja AL-B 23 23
2 AM
4 Nein AM-A 24 24
2 AN
4 Nein AN-A 25 25
2 AO
4 Nein AO-A 26 26
2 AP
4 Ja AP-A 27 27
2 AQ
4 Ja AQ-A 28 28
4 Ja AQ-B 29 29
1 B
2 BA
4 Ja BA-A 30 30
4 Ja BA-B 31 31
2 BB
4 Ja BB-A 32 32
1 C
3 C-A
4 Ja C-AA 33 33
4 Nein C-AB 34 34
3 C-B
4 Ja C-BA 35 35
1 D
2 DA
4 Nein DA-A 36 36
4 Nein DA-B 37 37
2 DB
4 Nein DB-A 38 38
1 E
2 EA
4 Nein EA-A 39 39
4 Nein EA-B 40 40
2 EB
4 Nein EB-A 41 41
1 F
4 Nein F--A 42 42
4 Nein F--B 43 43
1 G
4 Nein G--A 44 44
4 Nein G--B 45 45
4 Nein G--C 46 46
4 Nein G--D 47 47
4 Nein G--E 48 48
1 H
2 HA
4 Nein HA-A 49 49
2 HB
4 Nein HB-A 50 50
2 HC
4 Nein HB-A 51 51
*Teil-Ergebnis* (aktuell)
Titel 1 Titel 1 Beschreibung Titel 2 Titel 2 Beschreibung Titel 3 Titel 3 Beschreibung Titel 4 Titel 4 Beschreibung Aktiv Kategorie1 Kategorie2
A AA AAA AAAA Ja 1 1
A AA AAA AAAB Ja 2 2
A AA AAA AAAC Ja 3 3
A AB AB-A Ja 4 4
A AB AB-B Ja 5 5
A AB AB-C Ja 6 6
A AC AC-A Nein 7 7
A AC AC-B Nein 8 8
A AD AD-A Ja 9 9
A AD AD-B Ja 10 10
*Aktueller Code*
Option Explicit

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

Danke &
Beste Grüße,
Jack
p.s. irgendwie funktioniert der Excel upload aktuell nicht bei mir, sonst hätte ich das mal als file hochgeladen

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread