Duplikate Entfernen und Aufsummieren mit Array
21.01.2020 16:48:06
Nermin
ich kriege mein Problem mit Schleifen gelöst allerdings dauert die Prozedur zu lange (ca. 3 min). Um es schneller hinzukriegen benötige ich ein Array, womit ich mich garnicht auskenne. Ausgangstabelle sieht ungefähr so aus, dass ich in Spalte A die Bezeichnung habe und Spalte B die Teilenr und dann in den Spalten C bis H die Menge des Bauteils abhängig vom Produkt und das Bauteil kommt öfter vor in der Tabelle. Als Ausgabe soll dann eine Tabelle sein wo das Bauteil nur einmal vorkommt aber die Menge wie oft im jeweiligen Produkt aufsummiert wird. Also Bauteil A kommt 16 mal vor in der Tabelle mit den jeweiligen mengen des Produktes und als Ergebnis soll dann Bauteil A nur einmal vorkommen (in einer Zeile) und in der jeweiligen Spalte (abhängig vom Produkt) die Menge. Bauteil A kommt 16 mal vor, davon bei Produkt A 2 mal, Produkt B, 5 mal und Produkt C 9 mal. Wie kriege ich das mit einem Array hin? Die Lösung die ich gefunden habe, addiert nur eine Spalte und gibt nur diese Spalte aus, wie erweitere ich das, damit es auch die anderen Spalten aufsummiert?
Kann den Code einer entsprechend anpassen?
Public Sub Zusammenfassen()
Dim MyDict As Object ' As Dictionary
Dim vTemp As Variant ' ein temporärer Array
Dim lTemp As Long ' der For/Next Schleifen Index zum Array
Dim sText As String ' Zusammenfassung der ggf. noch doppelten
Dim lLetzte As Long ' die letzte belegte Zeile in Spalte E
Dim lZeile As Long ' der For/Next Schleifen-Index - hier die Zeile
Dim lngLastRow As Long
Dim lngCounter As Long
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = "Test"
Set MyDict = CreateObject("Scripting.Dictionary")
' die Eingabe-Daten aus Performance-Gründen in ein Array kopieren
With ThisWorkbook.Worksheets("Teilematrix") ' den Tabellenblattnamen ggf. anpassen!
vTemp = .Range("A4:H4" & .Cells(.Rows.Count, 1).End(xlUp).Row) ' ggf. anpassen!
End With
' zusammenfassen der Begriffe und addieren der Werte
For lTemp = 1 To UBound(vTemp)
sText = vTemp(lTemp, 1)
MyDict(sText) = MyDict(sText) + Val(vTemp(lTemp, 8))
Next lTemp
For i = 4 To ThisWorkbook.Worksheets("Teilematrix").Cells(Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Worksheets("Teilematrix").Cells(i, 1).EntireRow.Delete
Next i
' Application.ScreenUpdating = False ' kein Bildschirm-Update mehr zulassen
' Ausgeben. Die Zielzellen müssen ggf. angepasst werden
With ThisWorkbook.Worksheets("Test")
lLetzte = 4 + .Cells(.Rows.Count, 1).End(xlUp).Row
' die im Dictionary gesammelten und addierten Werte ausgeben
.Range("A4").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)
.Range("C4").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.Items)
End With
' Application.ScreenUpdating = True ' das Bildschirm-Update wieder zulassen
End Sub
Danke! Beste Grüße,
Nermin