Option Explicit
Type myDoppelte_struct
sAdr As String
lAnz As Long
sText As String
End Type
Sub Excel_SucheDoppelteUndMelde()
'*** sucht das aktive Blatt nach doppelten Werten ab
'*** und meldet die Anzahl
Dim ws As Worksheet, r As Range, Zelle As Range
Dim lColAnf As Long, lColEnd As Long, lRowAnf As Long, lRowEnd As Long
Dim sp As Long, z As Long, y As Long, lAnz As Long
Dim v As Variant
Dim sText As String, sAdr As String, s As String
Dim bSchonVorhanden As Boolean
Dim f() As myDoppelte_struct, fCnt As Long
Set ws = ActiveSheet
Set r = ws.UsedRange
If r.Count < 2 Then MsgBox Nur eine Zelle beschrieben.: GoTo AUFRAEUMEN
lColAnf = ws.UsedRange.Column
lColEnd = ws.UsedRange.Columns.Count + ws.UsedRange.Column - 1
lRowAnf = ws.UsedRange.Row
lRowEnd = ws.UsedRange.Rows.Count + ws.UsedRange.Row - 1
ReDim f(1 To 100): fCnt = 0
For sp = lColAnf To lColEnd
For z = lRowAnf To lRowEnd
sText = Trim(ws.Cells(z, sp).Value)
If sText <> Then->leere Zellen nicht durchsuchen
bSchonVorhanden = False
For y = 1 To fCnt
If sText = f(y).sText Then bSchonVorhanden = True: Exit For
Next
If Not bSchonVorhanden Then
sAdr = ws.Cells(z, sp).Address(False, False)->Zell-Adresse
Set Zelle = r.Find(What:=ws.Cells(z, sp).Value, _
After:=ws.Cells(z, sp), _
LookIn:=xlValues, _
Lookat:=xlWhole)
lAnz = 1-> muß sich mindestens selbst finden
If sAdr <> Zelle.Address(False, False) Then
Do
Set Zelle = r.FindNext(Zelle)
If Zelle Is Nothing Then Exit Do
lAnz = lAnz + 1
If sAdr = Zelle.Address(False, False) Then Exit Do
Loop
fCnt = fCnt + 1
If UBound(f()) <= fCnt Then ReDim Preserve f(1 To fCnt + 100)
f(fCnt).sText = sText
f(fCnt).lAnz = lAnz
f(fCnt).sAdr = sAdr
End If
End If
End If
Next
Next
If fCnt = 0 Then
MsgBox Keine Doppelten vorhanden.
Else
lAnz = 0
s =
For y = 1 To fCnt
s = s & f(y).sAdr & & f(y).lAnz & mal: & f(y).sText & vbLf
lAnz = lAnz + 1
If lAnz > 10 Then
If lAnz <> fCnt Then s = s & vbLf & weitere ...
Exit For
End If
Next
MsgBox Doppelte vorhanden. & vbLf & vbLf & s
End If
AUFRAEUMEN:
Set ws = Nothing: Set r = Nothing: Set Zelle = Nothing
End Sub
