Sub Nachbarzelle_von_Leerzelle_löschen() 
 num_rows = Worksheets(1).UsedRange.Rows.Count 
 c = ActiveCell.Column  '=Spaltennr der aktiven Zelle 
 If MsgBox("Steht die Markierung in der zu durchlaufenden Spalte (" & Chr(64 + c) _ 
 & ")?", vbOKCancel, "Markierung ok?") = vbOK Then 
   For r = 1 To num_rows 
     If IsEmpty(Worksheets(1).Cells(r, c).Value) Then 
       With Worksheets(1).Cells(r, c + 1) 
         If Not (IsEmpty(.Value)) Then  'falls Nachbarzelle nicht leer 
           .Interior.ColorIndex = 3     'dann Rot einfärben 
           .ClearContents               'und Inhalt löschen 
         End If 
       End With 
     End If 
   Next r 
 End If 
End Sub 

Sub Zelldubletten_in_Zeilen_löschen() 
 'Zellen werden zeilenweise durchlaufen,jeweils nur bis zur ersten Leerzelle! 
 Application.ScreenUpdating = False  'ohne Bildschirmaktualisierung schneller 
 Application.DisplayStatusBar = True 'um Fortschritt anzuzeigen 
 num_rows = Worksheets(1).UsedRange.Rows.Count 
 fortschritt = -1 
 gelöschteZellen = 0 
 For r = 1 To num_rows 
   If Int(100 * r / num_rows) > fortschritt Then 
     fortschritt = Int(100 * r / num_rows) 
     Application.StatusBar = "Fortschritt: " & fortschritt & "%" 
   End If 
   c1 = 0 
   With Worksheets(1) 
     Do Until IsEmpty(.Cells(r, c1 + 1).Value) 'bis rechte Nachbarzelle leer 
       c1 = c1 + 1 
       c2 = c1 + 1 
       Do Until IsEmpty(.Cells(r, c2).Value)   'bis Zelle leer 
         If .Cells(r, c2).Value = .Cells(r, c1).Value Then 'bei gleichem Inhalt 
           .Cells(r, c2).Delete Shift:=xlToLeft            'Zelle löschen 
           gelöschteZellen = gelöschteZellen + 1 
         Else 
           c2 = c2 + 1                         'sonst Spalte weiterrücken 
         End If 
       Loop 
     Loop 
   End With 
 Next r 
 Application.ScreenUpdating = True 
 Application.StatusBar = False 
 Antwort = MsgBox("Es wurden " & gelöschteZellen & " Zellen gelöscht", vbOKOnly) 
End Sub