Option Explicit
Sub DoppelteZahlenSuchen3()
Const c_SPALTE = 3->entspricht Spalte c
Dim ws As Worksheet, wst As Worksheet
Dim r_Range As Range ->benutzter Bereich der Spalte
Dim Zelle As Range
Dim r_DoppeltZellen As Range ->gemerkter Bereich doppelter Zellen
Dim ersteAdresse As String, l_row_anf As Long, l_row_end As Long, s_tmp As Long
Dim d_test As Double, x As Long
->aktives Blatt setzen
Set ws = ActiveSheet
->benutzter Bereich der Spalte
Set r_Range = Intersect(ws.Columns(c_SPALTE), ws.UsedRange)
->Bildschirm-Update abstellen
Application.ScreenUpdating = False
->temporäres Blatt anlegen
Set wst = Worksheets.Add
->Format der ersten Spalte = Zahl ohne Nachkommastelle
wst.Columns(1).NumberFormat = 0
->den zu untersuchenden Bereich hineinkopieren
r_Range.Copy
wst.Cells(1, 1).PasteSpecial _
Paste:=xlValues, _
Operation:=xlNone, _
SkipBlanks:=True, _
Transpose:=False
wst.Columns(1).AutoFit
->Sortieren
wst.Columns(1).Sort key1:=wst.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
->alles was nicht Zahl und 15-stellig ist löschen
On Error Resume Next
For Each Zelle In wst.UsedRange
d_test = Zelle.Value
If Err.Number <> 0 Then
Err.Clear: Zelle.Value =
Else
If d_test < 100000000000000# Or d_test > 999999999999999# Then Zelle.Value =
End If
Next
wst.Columns(1).Sort key1:=wst.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
->letzte Zeile bestimmen
->doppelte Zahlen bestimmen
l_row_end = wst.Cells(wst.Rows.Count, 1).End(xlUp).Row
For x = 1 To l_row_end
If wst.Cells(x, 1).Value <> wst.Cells(x + 1, 1).Value Then wst.Cells(x, 1).Value =
Next
wst.Columns(1).Sort key1:=wst.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
->doppelte Zahlen nur einmal stehen lassen
l_row_end = wst.Cells(wst.Rows.Count, 1).End(xlUp).Row
For x = 1 To l_row_end
If wst.Cells(x, 1).Value = wst.Cells(x + 1, 1).Value Then wst.Cells(x, 1).Value =
Next
wst.Columns(1).Sort key1:=wst.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
-><<< jetzt sind nur noch doppelte Zahlen im Blatt enthalten >>>>
l_row_end = wst.Cells(wst.Rows.Count, 1).End(xlUp).Row
->alle Zahlen im tatsächlichen Bereich suchen und Bereich merken
Set r_DoppeltZellen = Nothing
For x = 1 To l_row_end
->Suchen
With r_Range
->nach der eigenen Zelle mit Suche beginnen
Set Zelle = .Find(What:=wst.Cells(x, 1).Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not Zelle Is Nothing Then
->erste Fundstelle merken
ersteAdresse = Zelle.Address
Do
->gefundene Zelle merken
If r_DoppeltZellen Is Nothing Then
Set r_DoppeltZellen = Zelle
Else
Set r_DoppeltZellen = Union(r_DoppeltZellen, Zelle)
End If
Set Zelle = .FindNext(Zelle) 'nächste suchen
If Zelle Is Nothing Then Exit Do 'nichts mehr gefunden ?
If Zelle.Address = ersteAdresse Then Exit Do->wieder erste Fundstelle ?
Loop
End If
End With
Next
->Wenn Doppelte vorhanden, dann fett,rot setzen
->entsprechende Ende-Meldung ausgeben
If Not r_DoppeltZellen Is Nothing Then
With r_DoppeltZellen: .Font.Bold = True: .Font.ColorIndex = 3: End With
MsgBox _
Doppelte Zahlen sind vorhanden. & vbLf & vbLf & _
r_DoppeltZellen.Count & Kennzeichnungen wurden durchgeführt. & vbLf & vbLf & _
Kennzeichen: fett, rot, _
vbCritical
Else
MsgBox Keine doppelte Zahlen vorhanden. :-) :-) :-)
End If
AUFRAEUMEN:
->temporäres Blatt löschen
Application.DisplayAlerts = False
wst.Delete
Application.DisplayAlerts = True
->Bildschirm-Update anstellen
Application.ScreenUpdating = True
Set ws = Nothing
Set r_Range = Nothing
Set Zelle = Nothing
Set r_DoppeltZellen = Nothing
Set wst = Nothing
End Sub