Hallo Thomas,
hier die Auflösung (dabei ist allerdings zu beachten, dass die Quelle richtig sortiert sein muss - erst nach Telefonnummer + darin dann nach ID, weil das Makro nicht selbst ermittelt, welches die niedrigste ID ist, sondern nur die Zeile stehen lässt, die er zuerst findet + alle restlichen Dublikate rausschmeißt):
Sub DoppelteAde()
Dim arr As Variant
Dim Dic As Object
Dim i As Long
Set Dic = CreateObject(„Scripting.Dictionary“)
With Worksheets(„Quelle“) 'ANPASSEN
arr = .Range(„A1:B“ & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
For i = 1 To UBound(arr)
If arr(i, 2) „“ Then
If Not Dic.Exists(arr(i, 2)) Then
Dic(arr(i, 2)) = arr(i, 1)
End If
End If
Next
With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A1“).Resize(Dic.Count) = _
TransposeDim(Dic.Items)
.Range(„B1“).Resize(Dic.Count) = _
TransposeDim(Dic.Keys)
End If
End With
End Sub
Private Function TransposeDim(v As Variant) As Variant
Dim i As Long
Dim tempArray As Variant
Debug.Print Join(v, „,“)
ReDim tempArray(1 To UBound(v) + 1, 1 To 1)
For i = 0 To UBound(v)
tempArray(i + 1, 1) = v(i)
Next
TransposeDim = tempArray
End Function
LG von Dani
P.S.: Vielen Dank noch mal für deine Mühe: Ohne dich hätten wir die Lösung nicht gefunden !!!
