ExcelBanter - Find and remove blanks

I have a sub that is supposed to find and remove blanks from a spreadsheet.
However it does not work anymore. I do not understand what is wrong with it.
The pupose of the sub is to search a spreadsheet for blanks and if the
contents of a cell is purely numeric then replace these blanks with nothing
e.g. if a cell contains 100 000 000 it shall be replaced by 100000000 but if
the contents are AA 3 it should not be changed. I might also add that I am
pasting in the info from another program into the spreadsheet. I do not know
if that has any importance. The code is:

Private Sub findAndRemoveBlanks()
Dim WB As Workbook
Dim SH As Worksheet
Dim rng, rCell As Range
Set WB = ActiveWorkbook
Set SH = WB.Sheets("Beräkning")
Set rng = SH.UsedRange

For Each rCell In rng.Cells
With rCell
If Not IsEmpty(.Value) Then
If Not UCase(.Value) Like "*[A-Z]*" Then
.Replace What:=" ", Replacement:=""
End If
End If
End With
Next rCell
End Sub

The code works fine if you write something in a cell and then check it but
it does not seem to work when pasting. If anyone has any idea how to solve
this I would be most greatful for any assistance that you can give me! Thank
you!