VBA Excel Stücklisten auflösen

ich habe folgendes Problem, soll in meinem Praktikum eine Excel Tabelle mit Stücklisten auflösen. Die Tabelle ist nach folgendem Muster gegeben:

Fertigteil /Komponente /Menge
a, 1, 1
a, 2, 2
a, 3, 1
a, 7, 1
b, 4, 1
b, 5, 2
b, 6, 1
c, 5, 1
c, 6, 1
c, 2, 2
d, 4, 2
d, 5, 1
5, 7, 1 Komponenten mit Unterkomponenten
5, 8, 2 werden in Fertig auch mit
8, 9, 2 Aufschlüsselung aufgeführt
8, 10, 1

Nun habe ich folgenden VBA Code geschrieben:

Sub test()
Dim zaehlerKomponente As Integer
Dim zaehlerFertig As Integer

zaehlergesamt = 0
zaehlerKomponente = 1
zaehlerFertig = 1
zaehlerSucheKomponente = 1
zaehlerSucheFertig = 1
zaehlerSucheKomponente1 = 1
zaehlerSucheFertig1 = 1

For a = 1 To 20
If Cells(a, 1) „“ Then
zaehlergesamt = zaehlergesamt + 1
Else
End If
Next a

For zaehlerKomponente = 1 To zaehlergesamt
For zaehlerFertig = 1 To zaehlergesamt

If Sheets(„Basis“).Cells(zaehlerKomponente, 2).Value = Sheets(„Basis“).Cells(zaehlerFertig, 1).Value Then
komponente = Sheets(„Basis“).Cells(zaehlerKomponente, 2).Value

For zaehlerSucheKomponente = 1 To zaehlergesamt
For zaehlerSucheFertig = 1 To zaehlergesamt

If Sheets(„Basis“).Cells(zaehlerSucheKomponente, 2).Value = komponente Then
If Sheets(„Basis“).Cells(zaehlerSucheKomponente, 2).Value = Sheets(„Basis“).Cells(zaehlerSucheFertig, 1).Value Then
For b = 1 To 1000

If Cells(b, 1) = „“ Then
Worksheets(„Basis“).Rows(zaehlerSucheFertig).Copy ’ Kopiere die Fertigteil Zeile
Rows(zaehlerSucheFertig).Select

Application.CutCopyMode = False
Selection.Copy
Rows(b).Select
Selection.Insert Shift:=xlDown 'Füge Sie ans Ende der Tabelle

zaehlergesamt = zaehlergesamt + 1 'setze den Zähler für das ende der Tabelle einen Schritt hoch
Exit For
Else
End If
Next b

Sheets(„Basis“).Cells(zaehlerSucheFertig, 1).Value = Sheets(„Basis“).Cells(zaehlerSucheKomponente, 1).Value
Sheets(„Basis“).Cells(zaehlerSucheFertig, 3).Value = Sheets(„Basis“).Cells(zaehlerSucheFertig, 3) * Cells(zaehlerSucheKomponente, 3).Value

Else
End If
Else
End If

Next zaehlerSucheFertig
Next zaehlerSucheKomponente
Else
End If

Next zaehlerFertig
Next zaehlerKomponente

End Sub

Mein Problem ist das dieser Code in einem Durchgang nur den einen Artikel aufschlüsselt.

Bsp:

b, 4, 1
b, 6, 1
b, 7, 2 Weil b aus 2 * der Komponente 5 besteht die aus Komponente 7 und 8 besteht
b, 9, 8
b, 10, 4

So ist das Fertigteil b komplett aufgeschlüsselt.

Wie kann ich das Programm so schreiben, das er mir alle Komponenten so auflöst ohne das manche Informationen verlohren gehen. Ich weis das das Programm ziemlich unübersichtlich geworden ist aber vieleicht können Sie mir trotzdem aus der Klemme helfen.

Die Endtabelle sollte so aussehen:

Fertig/Komponente/ Menge
a, 1, 1
a, 2, 2
a, 3, 1
a, 7, 1
b, 4, 1
b, 7, 1
b, 9, 8
b, 10, 4
b, 6, 1
c, 7, 1
c, 10, 2
c, 9, 4
c, 2, 2
d, 4, 2
d, 7, 1
d, 10, 2
d, 9, 4

Probier’s mal damit… Habe Deinen Code nicht studiert sondern selber was geschrieben. Der Gag liegt in dem Rekursiven Aufrufen der Funktion…

Habe leider wenig Zeit, um das Ganze noch genauer zu kommentieren, hoffe Du kommst damit klar…

Matthias

Sub test()
Dim targetRow As Integer
rowIdx = 1
targetRow = 1
Do Until ActiveSheet.Cells(rowIdx, 1).Value = „“
targetRow = getRow(ActiveSheet.Cells(rowIdx, 1).Value, ActiveSheet.Cells(rowIdx, 2).Value, ActiveSheet.Cells(rowIdx, 3).Value, targetRow)
rowIdx = rowIdx + 1
Loop
End Sub

Function getRow(parent As String, child As String, qty As Integer, targetRow As Integer)
finishCycle = False
For rowIdx = 1 To ActiveSheet.UsedRange.Rows.Count
If ActiveSheet.Cells(rowIdx, 1).Value = „“ Or rowIdx = ActiveSheet.UsedRange.Rows.Count Then
If finishCycle = False Then
ActiveSheet.Cells(targetRow, 10).Value = parent
ActiveSheet.Cells(targetRow, 11).Value = child
ActiveSheet.Cells(targetRow, 12).Value = qty
getRow = targetRow + 1
Else
getRow = targetRow
End If
Exit Function
ElseIf ActiveSheet.Cells(rowIdx, 1).Value = child Then
tempTarget = targetRow
targetRow = getRow(parent, ActiveSheet.Cells(rowIdx, 2).Value, ActiveSheet.Cells(rowIdx, 3).Value * qty, targetRow)
If targetRow > tempTarget Then finishCycle = True
End If
Next rowIdx
End Function