Macro para quitar espacios excesivos en Microsoft Excel

Código

Sub IB·QuitarEspaciosExcesivos()
Dim r As Range
On Error Resume Next
Set r = Application.InputBox("Selecciona el rango de celdas donde deseas quitar los espacios excesivos", "INGENIERÍA & BURÓTICA", Type:=8)
On Error GoTo 0
If r Is Nothing Then
Exit Sub
End If
For Each celda In r
celda.Value = Application.WorksheetFunction.Trim(celda.Value)
Next celda
MsgBox "Se han eliminado los espacios excesivos en el rango indicado.", , "INGENIERÍA & BURÓTICA"
End Sub