try:

Sub znajdz()

On Error Resume Next

For Each Cell In Selection
counter = 0
For i = 1 To Len(Cell)
If Cell.Characters(Start:=i - counter,
Length:=1).Font.Strikethrough Then
Cell.Characters(Start:=i - counter, Length:=1).Delete
If Cell.Characters(Start:=i - counter, Length:=2) =
Chr(32) & Chr(32) Then
Cell.Characters(Start:=i - counter,
Length:=2).Delete
End If
counter = counter + 1
End If
Next i
Next Cell
End Sub

this will leave you with double spaces somewhere
you may get rid of them by using CTRL+H (Edit-Replace)

HIH