Excel VBA - Tabellentransformation unter Berücksichtigung einer Baumstruktur

[Allan Sche Sar]

Hallo zusammen,
ich knappere gerade an einer kleinen Nuss (zumindest für mich nach einem Jahr des nicht programmieren).
Die Tabelle auf der linken Seite soll in die der rechten Seite überführt werden.
Der grün markierte Bereich wird sauber mit meinem Code abgefertigt, nur stimmt diese Logik eben nicht für die auf der linken Seite markierten gelben Bereiche.

Source File:

Target File (wie es sein sollte):

Sofern die Qty (Anzahl) > 1 ist, muss die Zeile zwei mal "kopiert" (im Hintergrund passieren dann noch andere Sachen doch für das Beispiel ist es hier nicht relevant) werden. Sofern es sich allerdings um ein übergeordnetes Level handelt - sprich es gibt eine Level Nummer mit einer grösseren Zahl darunter bis zur Grösse (7 gibt es das aktuell), soll es in der rechten Tabelle ebenfalls strukturiert dargestellt werden.

Leider sieht aufgrund meines Codes, das Ergebnis jedoch so aus:

Man könnte sagen ich suche eine Möglichkeit eine Baumstruktur darzustellen, wobei die Qty im Ergebnis pro Zeile eins beträgt. Oder mit andere Worten wenn es in der linken Tabelle Qty. 3 gibt, sollen es am Ende drei einzelne Zeilen geben.

Mein aktueller Code:

Int_LastRow_Source = WB_Source.Cells(Rows.Count, 3).End(xlUp).Row 'last row from column C (Item ID) at Source
    For i = 3 To Int_LastRow_Source
        Int_Qty = WB_Source.Cells(i, 9).Value
        For i_Qty = 1 To Int_Qty
            'only if source column is not filtered out
            If WB_Source.Cells(i, 1).RowHeight > 0 Then
                Int_LastRow_Target = WB_Target.Cells(Rows.Count, 1).End(xlUp).Row + 1 'last row from column A (Level) at Target
                WB_Target.Cells(Int_LastRow_Target, 1).Value = WB_Source.Cells(i, 2).Value 'Copy Level - Column B
                WB_Target.Cells(Int_LastRow_Target, 5).Value = WB_Source.Cells(i, 7).Value 'Copy Description - Column G
                WB_Target.Cells(Int_LastRow_Target, 6).Value = WB_Source.Cells(i, 3).Value 'Copy Description - Column C
            End If
        Next i_Qty
    Next i

 

[foxhunter]

Hallo,
prinzipiell sollte der Code in Ordnung sein - liegt wahrscheinlich an einem Detail. Mir ist aufgefallen, dass die Bilder nicht mit dem Code harmonieren, z.B.:

        Int_Qty = WB_Source.Cells(i, 9).Value

referenziert Spalte 9 =Spalte I , das Bild hat nur max. 8 Spalten (Spalte H)

WB_Target hat die Spalten 1,5,6 im Code , im Bild Spalten # 7-9
usw.

Wäre Klasse, wenn beides in Einklang bringen könntest

 

[Allan Sche Sar]

Habe ein Bild vom Originalen Source and Target file hochgeladen im ersten Beitrag.
Der Code wie er ist liefert allerdings nicht das Ergebnis wie mit Target File bezeichnet sondern das hier:

Wobei die gelb markierten Zeilen inkorrekt sind. Hier fehlt in meinem Code eine Prüfroutine, welche auf X level nach unten prüft, wie es sortiert werden müsste.
Mir ist noch kein schlauer Ansatz dazu eingefallen.

 

[foxhunter]

Ich versteh zwar die Anwendung nicht ganz, allerdings mit diesem Code sollte es -zumindest ansatzweise-gehen (konnte es leider nicht austesten, ich bitte ggf. Syntax-Error etc. mir zu verzeihen :-) )

Sub DoIt(byval sourcestartrow, byval LimitQty)
    Int_LastRow_Source = WB_Source.Cells(Rows.Count, 3).End(xlUp).Row 'last row from column C (Item ID) at Source
    For i = sourcestartrow To Int_LastRow_Source
      'only if source column is not filtered out
      If WB_Source.Cells(i, 1).RowHeight > 0 Then
        Int_Qty = WB_Source.Cells(i, 9).Value
        if i<Int_LastRow_Source then Int_Qty_next = WB_Source.Cells(i+1, 9).Value else Int_Qty_next = Int_Qty
        if Int_Qty_next>Int_Qty then
            Int_LastRow_Target = WB_Target.Cells(Rows.Count, 1).End(xlUp).Row + 1 'last row from column A (Level) at Target
            WB_Target.Cells(Int_LastRow_Target, 1).Value = WB_Source.Cells(i, 2).Value 'Copy Level - Column B  LEVEL
            WB_Target.Cells(Int_LastRow_Target, 5).Value = WB_Source.Cells(i, 7).Value 'Copy Description - Column G  Name
            WB_Target.Cells(Int_LastRow_Target, 6).Value = WB_Source.Cells(i, 3).Value 'Copy Description - Column C   ID
            j=i+1
            'find next visible row
            for j=i+1 to Int_LastRow_Source+1
                Row_Visible = WB_Source.Cells(j, 1).RowHeight > 0
                if Row_Visible then exit for
            next j
            'recursive call
            call DoIt(j,1)
        else
            if LimitQty>0  then Int_Qty=LimitQty
            For i_Qty = 1 To Int_Qty
                Int_LastRow_Target = WB_Target.Cells(Rows.Count, 1).End(xlUp).Row + 1 'last row from column A (Level) at Target
                WB_Target.Cells(Int_LastRow_Target, 1).Value = WB_Source.Cells(i, 2).Value 'Copy Level - Column B  LEVEL
                WB_Target.Cells(Int_LastRow_Target, 5).Value = WB_Source.Cells(i, 7).Value 'Copy Description - Column G  Name
                WB_Target.Cells(Int_LastRow_Target, 6).Value = WB_Source.Cells(i, 3).Value 'Copy Description - Column C   ID
            Next i_Qty
        End If
      End If ' hidden row
    Next i
End Sub

Erster Aufruf mit:

call DoIt(3,0)

 

[Allan Sche Sar]

Hallo @foxhunter
ich habe deinen Code in mein Programm überführt. Leider kommt nicht das Ergebnis heraus. Daher habe ich nun diesem Beitrag eine Musterdatei angefügt. Achtung die Filterung auf dem Tabellenblatt "Change" so beibehalten. Dieser Filter wird vom regulären Programm später gesetzt.

In der angefügten Datei siehst du das Ergebnis, wenn ich es durchlaufen lasse.
Es entspricht leider nicht den "Erwartungen".
Aktuell versuche ich noch keinen Code zu verstehe. Finde es schon verblüffend, wie mich eine andere Schreibeweise der Anweisungen so rausbringt es zu lesen

Datei auf meiner Dropbox: https://www.dropbox.com/scl/fi/p13u...est.xlsm?rlkey=h7hx3z4dx8h76lgnapb1cun0t&dl=0

 

[foxhunter]

Klasse Idee, mein Update:

Sub Test()

ret = DoIt(3, 0, 0)
Debug.Print ret
    
End Sub

Function DoIt(ByVal sourcestartrow, ByVal sourceendrow, ByVal LimitQty) As Long
    
    Dim i As Long
    Dim j As Long
    Dim i_Qty As Integer
    Dim WB_Source As Object
    Dim WB_Target As Object
    Dim Int_LastRow_Source As Long
    Dim Int_LastRow_Target As Long
    Dim Int_Qty As Integer
    

    Set WB_Source = ThisWorkbook.Worksheets("Change")
    Set WB_Target = ThisWorkbook.Worksheets("SN Record")
    
    If sourceendrow = 0 Then
        Int_LastRow_Source = WB_Source.Cells(Rows.Count, 3).End(xlUp).Row 'last row from column C (Item ID) at Source
    Else
        Int_LastRow_Source = sourceendrow
    End If
    For i = sourcestartrow To Int_LastRow_Source
      'only if source column is not filtered out
      If WB_Source.Cells(i, 1).RowHeight > 0 Then
        Int_Qty = WB_Source.Cells(i, 9).Value
        Int_Lvl = WB_Source.Cells(i, 2).Value
        If i < Int_LastRow_Source Then
            Int_Qty_next = WB_Source.Cells(i + 1, 9).Value
            Int_Lvl_next = WB_Source.Cells(i + 1, 2).Value
        Else
            Int_Qty_next = Int_Qty
            Int_Lvl_next = Int_Lvl
        End If
        'If WB_Source.Cells(i, 7).Value = "Level16" Then Stop 'debug
        If (Int_Lvl_next > Int_Lvl) Then
            If Int_Qty <> Int_Qty_next Then Debug.Print "not supported": Stop: End
            For idx_qty = 1 To Int_Qty
                Int_LastRow_Target = WB_Target.Cells(Rows.Count, 1).End(xlUp).Row + 1 'last row from column A (Level) at Target
                WB_Target.Cells(Int_LastRow_Target, 1).Value = WB_Source.Cells(i, 2).Value 'Copy Level - Column B  LEVEL
                WB_Target.Cells(Int_LastRow_Target, 5).Value = WB_Source.Cells(i, 7).Value 'Copy Description - Column G  Name
                WB_Target.Cells(Int_LastRow_Target, 6).Value = WB_Source.Cells(i, 3).Value 'Copy Description - Column C   ID
                j = i + 1
                'find next visible row
                For j = i + 1 To Int_LastRow_Source + 1
                    Row_Visible = WB_Source.Cells(j, 1).RowHeight > 0
                    If Row_Visible Then Exit For
                Next j
                'recursive call
                ret = DoIt(j, Int_LastRow_Source, 1)
                j = ret
            Next
            i = j
        ElseIf (Int_Lvl_next < Int_Lvl) Then
            Int_LastRow_Target = WB_Target.Cells(Rows.Count, 1).End(xlUp).Row + 1 'last row from column A (Level) at Target
            WB_Target.Cells(Int_LastRow_Target, 1).Value = WB_Source.Cells(i, 2).Value 'Copy Level - Column B  LEVEL
            WB_Target.Cells(Int_LastRow_Target, 5).Value = WB_Source.Cells(i, 7).Value 'Copy Description - Column G  Name
            WB_Target.Cells(Int_LastRow_Target, 6).Value = WB_Source.Cells(i, 3).Value 'Copy Description - Column C   ID
            DoIt = i
            Exit Function
        Else
            If LimitQty > 0 Then Int_Qty = LimitQty
            For i_Qty = 1 To Int_Qty
                Int_LastRow_Target = WB_Target.Cells(Rows.Count, 1).End(xlUp).Row + 1 'last row from column A (Level) at Target
                WB_Target.Cells(Int_LastRow_Target, 1).Value = WB_Source.Cells(i, 2).Value 'Copy Level - Column B  LEVEL
                WB_Target.Cells(Int_LastRow_Target, 5).Value = WB_Source.Cells(i, 7).Value 'Copy Description - Column G  Name
                WB_Target.Cells(Int_LastRow_Target, 6).Value = WB_Source.Cells(i, 3).Value 'Copy Description - Column C   ID
            Next i_Qty
            If LimitQty > 0 Then DoIt = i: Exit Function
        End If
      End If ' hidden row
    Next i
    DoIt = i
End Function

 

[Allan Sche Sar]

Hallo @foxhunter
lange Zeit war es von meiner Seite aus Ruhig, da ich mich mit anderen Dingen in meiner Freizeit beschäftigt hatte und versucht habe deinen Code zu verstehen.
leider bin ich nicht ganz dahinter gestiegen.

Anbei findest du eine abgewandelte Version der Tabelle "Change". Darin habe ich lediglich anfänglich nur ein Level 3 eingefügt und schon ist es in den Stopp gerannt.
Mir ist nicht recht klar, warum das Stopp Kriterium greift. Sofern das nächste Level höher ist, kann doch die Anzahl der Items auch höher sein.
Allerdings sagt hier der Code 2<>5 (was ja richtig ist), ist true und springt in den Stop.

Anbei eine neue Version der Testdatei (hinzufügt habe ich noch meine Funktion um die Tabelle zu Filter (Serial = False wird mit hidden belegt
https://www.dropbox.com/scl/fi/h7ox...st1.xlsm?rlkey=9zzxov1d0q8ehtfsudfhhgx66&dl=0

Würdest du dir bitte noch einmal die Zeit nehmen und es dir anschauen?