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
|