Sub xxxx()
Dim objDict As Object, arrErg(), rngC As Range, lngI As Long, arrKeys
Set objDict = CreateObject("Scripting.Dictionary")
For Each rngC In Range(Cells(2, 1), Cells(2, 1).End(xlDown))
objDict(rngC.Value & "_" & rngC.Offset(, 1).Value) = _
objDict(rngC.Value & "_" & rngC.Offset(, 1).Value) + rngC.Offset(, 2).Value
Next
arrKeys = objDict.Keys
ReDim arrErg(1 To objDict.Count, 1 To 3)
For lngI = 1 To objDict.Count
arrErg(lngI, 1) = Split(arrKeys(lngI - 1), "_")(0)
arrErg(lngI, 2) = Split(arrKeys(lngI - 1), "_")(1)
arrErg(lngI, 3) = objDict(arrKeys(lngI - 1))
Next
Range(Cells(2, 1), Cells(2, 1).End(xlDown)).Resize(, 3).ClearContents
Cells(2, 1).Resize(objDict.Count, 3) = arrErg
End Sub
Sub xxxx()
Dim rngDel As Range, rngC As Range
For Each rngC In Range(Cells(2, 1), Cells(2, 1).End(xlDown))
rngC.Offset(, 2) = Application.SumIf(Columns(1), rngC, Columns(3))
If Application.CountIf(Range(Cells(2, 1), rngC), rngC) > 1 Then
If rngDel Is Nothing Then
Set rngDel = rngC
Else
Set rngDel = Union(rngDel, rngC)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End SubDie erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen