AW: Paare finden - keine Paare markieren
22.05.2019 10:47:41
peterk
Hallo
Probier mal (Tabellen Namen anpassen, speziell für die Auswertung!)
Sub CheckP()
Dim maxCells As Long
Dim i As Long
Dim objDict As Object
Dim objDictLast As Object
Dim DictKey As Variant
With Worksheets("Tabelle2") 'Tabellenname anpassen
maxCells = .Cells(.Rows.Count, 1).End(xlUp).Row
Set objDict = CreateObject(Class:="Scripting.Dictionary")
Set objDictLast = CreateObject(Class:="Scripting.Dictionary")
For i = 1 To maxCells
If Not objDict.Exists(Key:=.Cells(i, 1).Value) Then
objDict.Add Key:=.Cells(i, 1).Value, Item:=1
Else
objDict(.Cells(i, 1).Value) = objDict(.Cells(i, 1).Value) + 1
End If
If Not objDictLast.Exists(Key:=.Cells(i, 1).Value) Then
objDictLast.Add Key:=.Cells(i, 1).Value, Item:=i
Else
objDictLast(.Cells(i, 1).Value) = i
End If
Next i
End With
For Each DictKey In objDict.keys
If objDict.Exists(Key:=DictKey * (-1)) Then
If objDict(DictKey * (-1)) < objDict(DictKey) Then
objDict(DictKey) = objDict(DictKey) - objDict(DictKey * (-1))
objDict(DictKey * (-1)) = 0
Else
objDict(DictKey * (-1)) = objDict(DictKey * (-1)) - objDict(DictKey)
objDict(DictKey) = 0
End If
End If
Next DictKey
' Auswertung (Tabellenname anpassen!)
i = 1
For Each DictKey In objDict.keys
If objDict(DictKey) <> 0 Then
Worksheets("Tabelle2").Cells(i, 3) = DictKey ' Wert
Worksheets("Tabelle2").Cells(i, 4) = objDict(DictKey) ' Anzahl
Worksheets("Tabelle2").Cells(i, 5) = objDictLast(DictKey) ' lezte Zeile
i = i + 1
End If
Next DictKey
Set objDict = Nothing
Set objDictLast = Nothing
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0