Duplikate makieren damit sie danach entfernt werden können

Option Explicit

Type my_TelefonnummernListe
 sTelNr As String
 lZeile As Long
 bDoppelt As Boolean
End Type

Sub DoppelteTelefonnummernMarkieren()

->Makro nimmt den jeweiligen Zellinhalt als Text und filtert ihn
->auf Nummern 0-9
->Das Makro überprüft, ob diese Nummer in der Spalte noch einmal auftaucht
->Diese Zellen werden hellorange markiert
 
->*** A N P A S S E N ****
-> Nummer der Spalte mit Telefonnummern
-> 1 für A, 2 für B, ...
 Const cSP_TELNRN = 1
->ab Zeile 2 prüfen
 Const cZ_ERSTEWERTEZEILE = 2
->*** A N P A S S E N E N DE ****
 
 Const cFARBE = 46->Colorindex hellorange
 
 Dim ws As Worksheet
 Dim f() As my_TelefonnummernListe, fCnt As Long
 Dim lZeilen As Long, x As Long, y As Long
 Dim sTmp As String, sTel As String, s As String
 Dim bEsGibtDoppelte As Boolean
 
->actives Blatt setzen
 Set ws = ActiveSheet
 
->letzte Zeile mit Inhalt in Spalte bestimmen
 lZeilen = ws.Cells(ws.Rows.Count, cSP_TELNRN).End(xlUp).Row
 If lZeilen <= cZ_ERSTEWERTEZEILE Then
  MsgBox keine relevaten Zeilen in Spalte  & cSP_TELNRN & vorhanden.
  GoTo AUFRAEUMEN
 End If
 
->Telefonnummern einlesen
 fCnt = 0
 ReDim f(1 To lZeilen)
 For x = cZ_ERSTEWERTEZEILE To lZeilen
  
  sTmp = ws.Cells(x, cSP_TELNRN).Value
  
 ->alles ungleich Ziffern ausfiltern
  sTel = 
  For y = 1 To Len(sTmp)
   s = Mid(sTmp, y, 1)
   Select Case s
    Case 0 To 9
     sTel = sTel & s
   End Select
  Next
  
  If Len(sTel) > 0 Then
  ->Telefonnummer merken
   fCnt = fCnt + 1
   f(fCnt).sTelNr = sTel
   f(fCnt).lZeile = x
  End If
 Next
 
->TelNummern vergleichen, Doppelte markieren
 For x = 1 To fCnt
  For y = 1 To fCnt
   If x <> y Then
    If f(x).sTelNr = f(y).sTelNr Then
     bEsGibtDoppelte = True
     f(x).bDoppelt = True
     ws.Cells(f(x).lZeile, cSP_TELNRN).Interior.ColorIndex = cFARBE
    End If
   End If
  Next
 Next
 If Not bEsGibtDoppelte Then
  MsgBox keine doppelten Telefonnummern vorhanden.
  GoTo AUFRAEUMEN
 End If
 
AUFRAEUMEN:
 Set ws = Nothing
End Sub