Hallo liebe Forumsmitglieder,

derzeit stehe ich vor einem kleinen Problem. Ich habe einen Codebaustein geringfügig umgeschrieben, welcher einen Datensatz konsolidiert. Konkret heißt das, dass doppelte Einträge in der Spalte X dazuführen, dass in einer neuen Arbeitsmappe die Informationen aus Spalte Y nummeriert in der gleichen Zeile als neue Spalte hinzugefügt werden.

Beispiel: 
Ausgangsdatensatz

Hersteller X----->Produkt A
Hersteller X----->Produkt B
Hersteller Y ----->Product C

wird zu:

Hersteller X ------->Produkt A-------->Produkt B
Hersteller Y------->Product C

Je öfter eine Überschneidung im der Herstellerzeile vorkommt, desto mehr Spalten werden hinzugefügt und die Informationen werden kopiert ... 

Nun brauche ich noch einmal eine Konsolidierung der neu hinzugefügten Spalten in einer Spalte. Hier habe ich versucht einen verschachtelten Loop zu bauen, damit zunächst die Spalten ineinander kopiert und darauf dieser Vorgang für alle Zeilen durchgeführt wird. Leider habe ich hier wohl einen Fehler drin, da das ineinander kopieren auch nur passieren soll, wenn die Zellendaten enthalten.

Mein bisheriger, kompletter Code:

Sub Consolidation()
   Dim zz&, wsnQ$, anZ&, anS&, dum$, maxWied As Byte, SpZ%(), ii%, jj%, pp%
   Dim wsIni As Worksheet, wsQ As Worksheet, wsZ As Worksheet
   Dim src As Range
   Dim x As Integer
   Dim bb As Integer
   Dim tt As Integer
   
   
   '                                                       Ini vorbereiten
   Set wsIni = Sheets("Cockpit")
   wsIni.Activate
   Columns("E:G").Delete
   '                                          Ziel-Blatt löschen, wenn ex.
   On Error Resume Next
   Sheets(wsIni.Cells(6, 2) & "").Delete
   On Error GoTo 0
   '                                            Quelldaten-Zeilen/-Spalten
   wsnQ = Cells(4, 2)
   Set wsQ = Sheets(wsnQ)
   anZ = Sheets(wsnQ).[A1].CurrentRegion.Rows.Count
   anS = Sheets(wsnQ).[A1].CurrentRegion.Columns.Count
   '                                        max. Anzahl Key-Wiederholungen
   dum = "'" & wsnQ & "'!" & Cells(5, 2) & "1:" & Cells(5, 2) & CStr(anZ)
   Cells(1, 5).FormulaArray = "=MAX(1*COUNTIF(" & dum & "," & dum & "))"
   maxWied = Cells(1, 5)
   Cells(1, 5).ClearContents
   ReDim SpZ(1 To maxWied, 1 To anS)
   '                                                Eintrag Ini-Hilfswerte
   Range(Cells(3, 5), Cells(3, 7)) = Split("von bis vor")
   zz = 8
   While Not IsEmpty(Cells(zz + 1, 1))
      zz = zz + 1
      Cells(zz, 5) = SpNumm(Cells(zz, 1))
      Cells(zz, 6) = SpNumm(Cells(zz, 2))
      Cells(zz, 7) = SpNumm(Cells(zz, 3))
   Wend
   '                                                   Sort Ini-Hilfswerte
   Range(Cells(5, 5), Cells(zz, 7)).Sort _
      Key1:=Range("G6"), Order1:=xlDescending, _
      Key2:=Range("E6"), Order2:=xlDescending, _
      Header:=xlYes, OrderCustom:=1, Orientation:=xlTopToBottom
   '                                                   Sort der Quelldaten
   wsQ.Activate

   '                            neues Blatt, Spaltenüberschriften kopieren
   Set wsZ = Worksheets.Add(After:=Sheets(1))
   wsZ.Name = wsIni.Cells(6, 2)
   wsQ.Rows(1).Copy Destination:=wsZ.Cells(1, 1)
   '                                zusätzl. Spaltenüberschriften einfügen
   zz = 5
   While Not IsEmpty(wsIni.Cells(zz + 1, 1))
      zz = zz + 1
      For ii = maxWied - 1 To 1 Step -1
         For jj = wsIni.Cells(zz, 6) - wsIni.Cells(zz, 5) To 0 Step -1
            wsQ.Cells(1, wsIni.Cells(zz, 5) + jj).Copy
            wsZ.Cells(1, wsIni.Cells(zz, 7)).Insert Shift:=xlToRight
            wsZ.Cells(1, wsIni.Cells(zz, 7)) = _
               wsZ.Cells(1, wsIni.Cells(zz, 7)) & " #" & CStr(ii + 1)
         Next jj
      Next ii
   Wend
   
   Application.CutCopyMode = False
   wsIni.Columns("E:G").Delete

   '                                                     Datenziele merken
   ii = 0
   For zz = 1 To wsZ.UsedRange.Count
      pp = InStr(wsZ.Cells(1, zz), "#")
      If pp > 0 Then
         For jj = 1 To ii
            If Left(wsZ.Cells(1, zz), pp - 2) = wsQ.Cells(1, jj) Then
               SpZ(Mid(wsZ.Cells(1, zz), pp + 1), jj) = zz
               Exit For
            End If
         Next jj
      Else
         If Not IsEmpty(wsZ.Cells(1, zz)) Then
            ii = ii + 1:  SpZ(1, ii) = zz
         End If
      End If
   Next zz
   '                                                      Daten übertragen
   jj = 1: dum = ""
   For zz = 2 To anZ
      If dum = wsQ.Cells(zz, SpNumm(wsIni.Cells(5, 2))) Then
         ii = ii + 1
      Else
         ii = 1:          jj = jj + 1
         dum = wsQ.Cells(zz, SpNumm(wsIni.Cells(5, 2)))
      End If
      For pp = 1 To anS
         If SpZ(ii, pp) > 0 Then wsZ.Cells(jj, SpZ(ii, pp)) = wsQ.Cells(zz, pp)
      Next pp
   Next zz
   Cells(2, 1).Select
   
   ActiveSheet.Range("H2", "H1000").NumberFormat = "m/d/yyyy"
   ActiveSheet.Range("L2", "L1000").NumberFormat = "m/d/yyyy"
   
        Columns("W:W").Insert Shift:=xlToRight, _
      CopyOrigin:=xlFormatFromLeftOrAbove
      Range("W1") = "Licenses/ Contracts Consolidation"
      
'Starten mit x in Spalte 3

bb = maxWied
tt = maxWied - 1
x = 2


Do While Cells(x, 24).Value <> ""


Cells(x, 23).Value = "-" & Cells(x, 23 + bb).Value

    Do While tt > 0 And IsNumeric(Cells(x, 23 + bb))
    

    Cells(x, 23).Value = Cells(x, 23).Value & vbCrLf & "-" & Cells(x, 23 + tt).Value
    Exit Do
    tt = tt - 1
    
Loop

x = x + 1

Loop

    
    Range("A:A").Columns.Hidden = True
Set src = Range("A1:AE600").CurrentRegion
ActiveSheet.ListObjects.Add(SourceType:=xlSrcRange, Source:=src, _
xlListObjectHasHeaders:=xlYes, tablestyleName:="TableStyleMedium2").Name = "Consolidation"
   
   ActiveWindow.FreezePanes = True
End Sub

Allerdings ist die konkrete Stelle, an der es klemmt diese hier:

bb = maxWied
tt = maxWied - 1
x = 2


Do While Cells(x, 24).Value <> ""


Cells(x, 23).Value = "-" & Cells(x, 23 + bb).Value

    Do While tt > 0 And IsNumeric(Cells(x, 23 + bb))
    

    Cells(x, 23).Value = Cells(x, 23).Value & vbCrLf & "-" & Cells(x, 23 + tt).Value
    Exit Do
    tt = tt - 1
    
Loop

x = x + 1

Loop

Ich hoffe mir kann jemand weiterhelfen und verraten, wie ich die Loops ineinander verschachteln muss, damit es funktioniert ... 

Vielen Dank im Voraus und liebe Grüße,

Tim