|
Dachte eigentlich, dass es recht einfach sein müssete, aber so einfach wars dann doch nicht:
Option Explicit
Function getDuplicateCount() As Long
Dim a&, b&, c&, I&, J&, LR&, E&, V, Dup As Boolean, Unique(), Dups&
Dim AV
LR = Cells(Rows.Count, 1).End(xlUp).Row
AV = Range("A1:A" & LR).Value
If LR = 1 Then Exit Function
E = UBound(AV)
For a = 1 To E
V = AV(a, 1)
For c = 0 To I - 1
If V = Unique(c) Then
Dup = True
Exit For
End If
Next
If Dup Then
Dup = False
Else
ReDim Preserve Unique(I)
Unique(I) = V
I = I + 1
End If
Next
For c = 0 To I - 1
V = Unique(c)
J = 0
For a = 1 To E
If AV(a, 1) = Unique(c) Then
J = J + 1
If J > 1 Then
Dups = Dups + 1
Exit For
End If
End If
Next
Next
MsgBox Dups & " Duplikate und " & I & " Einzigartige"
End Function
Sollte soweit funktionieren, wenn ich dich richtig verstanden habe. Falls du eine schnellerw/effizientere/bessere oder einfachere Möglichkeit siehst würde ich mich freuen, wenn du sie hier reinstellen würdest.
Till
|