Office: Stückliste mit VBA auflösen- Function die sich wieder selber aufruft?

Liste mit VBA auflösen- Function die sich wieder selber aufruft?

Hallo,
ich möchte eine Einstufige Liste Mehrstufig mit VBA auflösen.

In Spalte A steht ein Material, welches in Spalte B eine Unterkomponente hat. Diese Komponente kann/muss aber nicht eine Unterkomponente haben. Anhand der Unterstufen soll die Menge immer in einer Spalte weiter stehen. Ich hoffe ihr versteht was ich meine....Ich muss also mit der ersten Schleife jedes Material in Spalte A nach den Unterkomponenten suchen und da wiederum eine andere Schleife starten um eventuell noch eine Unterkomponente zu finde. Wenn keine weitere Komponente gefunden wurde, soll mit dem nächsten Material weitergearbeitet werdenn.

Ich benutze Excel 2010
Danke

 

Hier mein Code bisher:

Code:

Sub Start()
     Dim wksA As Worksheet, i&, arrBereich As Variant
     
     Set wksA = ThisWorkbook.Worksheets("A")
     With wksA
          i = 3
          Do While .Cells(i, 1) <> ""
               arrBereich = .Range(.Cells(i, 1), .Cells(i, 3))
               .Cells(i, 17).Resize(1, 3) = arrBereich
               Aufloesen .Cells(i, 1), .Cells(i, 2), wksA, i
          i = i + 1
          Loop
     End With
End Sub

Function Aufloesen(strArtikel$, strKomp$, wksA As Worksheet, i&)
     Dim Z&
     With wksA
          For Z = i To .UsedRange.Rows.Count
               If .Cells(Z, 1) = strKomp Then
                    .Cells(i + 1, 18) = .Cells(Z, 2)
                    .Cells(i + 1, 19) = .Cells(Z, 3)
                    i = i + 1
                    Aufloesen .Cells(Z, 1), .Cells(Z, 2), wksA, i
               End If
          Next Z
     End With
End Function

Die ersten 5 Zeilen kommt auch das richtige Ergebnis, aber danach überspringt das Programm die Zeilen...

 

Hallo,

nachfolgend der Code, der bei mir funktioniert hat. Er produziert ein Ergebnis, das zu Deinem, wie Du es im JPG-Dateianhang zeigst, identisch ist.
(Der von Dir beigefügte Code geht von anderen Ausgabespalten aus als das JPG-Bild).

Code:

Sub Material_Komponenten()
  Dim wksA As Worksheet
  Dim rngUrdaten As Range
  Dim MatZeile As Range, AktMat As String
  Dim EgZl As Long, EgSp As Long
  
  Set wksA = ThisWorkbook.Worksheets("A")
  With wksA
  
     'Urdatenbereich: im Beispiel A4:C27
     With .Cells(3, 1).CurrentRegion
       Set rngUrdaten = .Offset(4 - .Row, 0).Resize(.Rows.Count - 4 + .Row, 3)
     End With
     
     'Ergebnisbereich: ab Zelle E4
     EgZl = 4      'Ergebniszeile für Mat/Komp/Menge (=Zeile 4)
     EgSp = 7      'Ergebnisspalte für Menge (=Spalte G)
     
     AktMat$ = ""  'Aktuelles Urdaten-Material (Spalte A), das untersucht wird
     For Each MatZeile In rngUrdaten.Rows
       If MatZeile.Cells(1) <> AktMat$ Then
         'In der neuen Urdatenzeile ist gegenüber der Vorzeile anderes Material enthalten
         AktMat$ = MatZeile.Cells(1)       'Neues aktuelles Urdaten-Material
         .Cells(EgZl, 5) = AktMat$         'Ergebnis-Material
       End If
       .Cells(EgZl, 6) = MatZeile.Cells(2) 'Ergebnis-Komponente
       .Cells(EgZl, 7) = MatZeile.Cells(3) 'Ergebnis-Menge (Spalte 7 = "G")
       Unterkomponente wksA, MatZeile.Cells(2), rngUrdaten, EgZl, EgSp + 1
     Next MatZeile
  End With
End Sub
Sub Unterkomponente(wks As Worksheet, AktMat$, ByVal rngUrdaten As Range, EgZl&, EgSp&)
  Dim MatFund As Range
  Dim MatZeile As Range
  With wks
    
    EgZl = EgZl + 1   'Ergebnis-Zeile erhöhen
    
    'AktMat$ wird in der Urdaten-Materialspalte gesucht
    Set MatFund = rngUrdaten.Columns(1).Find(What:=AktMat$, LookAt:=xlWhole, LookIn:=xlValues)
    If MatFund Is Nothing Then
      'AktMat$ wurde nicht im Urdaten-Material gefunden:
      'daher wird die rekursive Material/Komponenten-Suche beendet:
      Exit Sub
    Else
      'Verkleinerter Urdatenbereich
      With rngUrdaten
        Set rngUrdaten = Range(MatFund, .Cells(.Rows.Count, 3))
      End With
      
      For Each MatZeile In rngUrdaten.Rows
        If MatZeile.Cells(1) = AktMat$ Then
          'In der neuen Urdatenzeile ist immer noch das gesuchte Material enthalten
          .Cells(EgZl, 6) = MatZeile.Cells(2)     'Ergebnis-Komponente
          .Cells(EgZl, EgSp) = MatZeile.Cells(3) 'Ergebnis-Menge (Spalte EgSp)
        Else
          'In der neuen Urdatenzeile ist nicht mehr das gesuchte Material enthalten:
          'daher beende die Rekursion und verlasse die SUB
          Exit Sub
        End If
        Unterkomponente wks, MatZeile.Cells(2), rngUrdaten, EgZl, EgSp + 1
      Next MatZeile
      
    End If
    
  End With
End Sub

 

Super! Danke, perfekt!!!!

 

Wie könnte man das ganze etwas flotter abarbeiten? Bei großen Datenmengen dauert das echt ewig... jemand eine Idee?