Hi iMa,

zum "Nachdenken" ;)

Option Explicit
Dim lRow As Long, lCol As Long  'letzte Zeile, Spalte
Dim sRng As Range, c As Range   'durchsuchter Bereich, Zelle
Dim k As Range, q As Range    'Suche
Public mColor As Long              'Farbe

Sub Test()
'zu Testzwecken werden die Duplikate nur eingefärbt

lRow = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
lCol = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
Set sRng = Range(Cells(2, 1), Cells(lRow, lCol))

Application.ScreenUpdating = False

  mColor = 0
  NamedColumn "Spalte ist vorgegeben - jede Zelle in der Spalte nach unten"

  '**********************************************
  ' oder eine andere Methode ??
  ' wie jede Zeile mit darunter liegender Zeile ?
  ' jede Zelle mit darunter liegenden Zellen ????

  If mColor <> 0 Then
    If DoIt("sofort löschen") Then TestErgebnisLöschen
  End If
  
Application.ScreenUpdating = True

End Sub

Sub TestErgebnisLöschen()
Dim x As Long, y As Long
'eingefärbte Zeilen löschen
  
  If mColor = 0 Then Exit Sub
  
  For x = lRow To 2 Step -1
    For y = 1 To lCol
      If Cells(x, y).Interior.Color = mColor Then
        Rows(x).Delete
        Exit For
      End If
    Next y
  Next x
  mColor = 0
  
End Sub

Private Sub NamedColumn(Hint)
  Dim mCol As Long  'Auswahl Spalte
  Dim x As Long
  
  If Not DoIt(Hint) Then Exit Sub
  
  mColor = RGB(255, 0, 0)
  
  On Error GoTo errorhandler
  mCol = CLng(InputBox("Spalte als Zahl : ", , "1"))
  On Error GoTo 0
  If mCol > lCol Then Exit Sub
  
  CleanUp 'Bereinigung
  
  Set sRng = Range(Cells(2, mCol), Cells(lRow, mCol))
  
  For Each c In sRng
    If c.Value <> "" Then
      For x = c.Row + 1 To lRow
        If Cells(x, mCol).Value = c.Value Then
          Cells(x, mCol).Interior.Color = mColor
        End If
      Next x
    End If
  Next c
  
Exit Sub
errorhandler:
On Error GoTo 0
End Sub

Private Function DoIt(Hint) As Boolean
  If MsgBox(Hint, vbOKCancel, "Methode starten") = 1 Then DoIt = True
End Function

Private Sub CleanUp()
 With Cells.Interior
    .Pattern = xlNone
    .TintAndShade = 0
    .PatternTintAndShade = 0
  End With
End Sub