Option Explicit
Dim lRow As Long, lCol As Long
Dim sRng As Range, c As Range
Dim k As Range, q As Range
Public mColor As Long
Sub Test()
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"
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
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
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
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