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