Excel Funktion

Sub DoppelteZahlenSuchen()

  Const c_SPALTE = 3->entspricht Spalte c
  
  Dim ws As Worksheet
  Dim r_Range         As Range ->benutzter Bereich der Spalte
  Dim Zelle1          As Range ->Zelle deren Inhalt gesucht wird
  Dim Zelle2          As Range ->gefundenen Zelle, deren Inhalt mit Zelle1 übereinstimmt
  Dim r_DoppeltZelle1 As Range ->gemerkter Bereich doppelter Zellen bzgl.der momentanen Zelle
  Dim r_Doppelt       As Range ->gemerkter gesamter Bereich der doppelten Zellen
  
  Dim ersteAdresse As String
  
 ->aktives Blatt setzen
  Set ws = ActiveSheet
  
 ->benutzter Bereich der Spalte
  Set r_Range = Intersect(ws.Columns(c_SPALTE), ws.UsedRange)
  
 ->alle zellen prüfen
  For Each Zelle1 In r_Range
    
   ->nur 15stellige strings prüfen
    If Len(Zelle1.Value) = 15 Then
      
      Set r_DoppeltZelle1 = Nothing
     ->Suchen
      With r_Range
       ->nach der eigenen Zelle mit Suche beginnen
        Set Zelle2 = .Find(After:=Zelle1, What:=Zelle1.Value, LookIn:=xlValues, Lookat:=xlWhole)
        If Not Zelle2 Is Nothing Then
         ->Zelle selbst erstmal nicht berücksichtigen
          If Zelle1.Address <> Zelle2.Address Then
           ->erste Fundstelle merken
            ersteAdresse = Zelle2.Address
            
            Do
              If r_DoppeltZelle1 Is Nothing Then
               ->gefundene Zelle merken
                Set r_DoppeltZelle1 = Zelle2
              Else
               ->gefundene Zelle den bereits gemerkten hinzufügen
                Set r_DoppeltZelle1 = Union(r_DoppeltZelle1, Zelle2)
              End If
                
             ->nächste suchen
              Set Zelle2 = .FindNext(Zelle2)
             ->nichts mehr gefunden ?
              If Zelle2 Is Nothing Then Exit Do
             ->Zelle selbst ?
              If Zelle2.Address = Zelle1.Address Then Exit Do
             ->wieder erste Fundstelle ?
              If Zelle2.Address = ersteAdresse Then Exit Do
            Loop
            
           ->eine doppelte gefunden ?
            If Not r_DoppeltZelle1 Is Nothing Then
             ->Zellen zum gesamten Doppelten Bereich hinzufügen
              If r_Doppelt Is Nothing Then
                Set r_Doppelt = Union(r_DoppeltZelle1, Zelle1)
              Else
                Set r_Doppelt = Union(r_Doppelt, r_DoppeltZelle1, Zelle1)
              End If
            End If
          End If
        End If
      End With
    End If
  Next

 ->Wenn Doppelte vorhanden, dann fett,rot setzen
 ->entsprechende Ende-Meldung ausgeben
  If Not r_Doppelt Is Nothing Then
    With r_Doppelt: .Font.Bold = True: .Font.ColorIndex = 3: End With
    MsgBox _
      Doppelte Zahlen sind vorhanden. & vbLf & vbLf & _
      r_Doppelt.Count &  Kennzeichnungen wurden durchgeführt. & vbLf & vbLf & _
      Kennzeichen: fett, rot, _
      vbCritical
  Else
    MsgBox _
      Keine doppelte Zahlen vorhanden. :-) :-) :-)
  End If
  
AUFRAEUMEN:
  Set ws = Nothing: Set r_Range = Nothing: Set Zelle1 = Nothing: Set Zelle2 = Nothing
  Set r_DoppeltZelle1 = Nothing: Set r_Doppelt = Nothing
End Sub

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