Doppelte Werte markieren

Sub zellen_mit_doppelten_einträgen_markieren()
On Error GoTo Fehlerbehandlung
Dim Spalten As Object
Dim zelle1 As Object
Dim zelle2 As Object
Dim f As Integer
Dim eing
f = 0
Set zelle1 = Selection.SpecialCells(xlLastCell).Offset(1, 1)
Set zelle2 = Selection.SpecialCells(xlLastCell)
Set Spalten = ActiveCell.CurrentRegion
eing = InputBox("Die Zelle eingeben, ab der geprüft werden soll," & (Chr(13)) & "z.B. A1 oder   _
_
F6.", "Zellenauswahl")
Range(eing).Select
eing = ""
Application.ScreenUpdating = False
zelle1 = ActiveCell
ActiveCell.Offset(1).Select
For x = 1 To Spalten.Rows.Count
If ActiveCell.Value = zelle1 Then
If ActiveCell  "" Then
ActiveCell.Interior.ColorIndex = 43
End If
End If
ActiveCell.Offset(1).Select
Next x
For i = 1 To Spalten.Rows.Count - 1
For z = 1 To Spalten.Rows.Count
ActiveCell.Offset(-1).Select
Next z
f = f + 1
zelle1.Clear
zelle2 = ActiveCell
ActiveCell.Offset(1).Select
For y = 1 To Spalten.Rows.Count
If ActiveCell.Value = zelle2 Then
If ActiveCell  "" And Selection.Interior.ColorIndex = xlNone Then
ActiveCell.Interior.ColorIndex = 43 + f
End If
End If
ActiveCell.Offset(1).Select
Next y
Next i
zelle2.Clear
Application.ScreenUpdating = True
Range("A1").Select
Fehlerbehandlung:
If Err = 1004 Then
MsgBox "Es wurde keine Zelle angegeben!", , "Fehler 1004"
Else
MsgBox Error(Err)
End If
End Sub

Bei diesem Makro wird allerdings immer erst der zweite Wert farbig markiert. Beisipiel:
5 keine Farbe
6 keine Farbe
5 Farbe
Es müsste aber auch die erste 5 mit der gleichen Farbe markiert werden.
Wie muss ich das anstellen? Vielen Dank!
Viele Grüße
Markus