How to Optimize This Code?

I tried adapting the code to skip dates and text and it seems to have worked faster, although it still demands a couple hours. I will keep using this for now, until and if someone has any other idea that could help.

Sub MultiFindNReplace()
'Update 20140722
    Dim Rng        As Range
    Dim InputRng   As Range
    Dim ReplaceRng As Range
    Dim xTitleId   As String
    xTitleId = "KutoolsforExcel"
    With Application
        Set InputRng = .InputBox("Original Range ", xTitleId, Selection.Address, Type:=8)
        Set ReplaceRng = .InputBox("Replace Range :", xTitleId, Type:=8)
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        For Each Rng In ReplaceRng.Columns(1).Cells
            If Not IsDate(Rng.Value) Then
            If IsNumeric(Rng.Value) Then
                InputRng.Replace what:=Rng.Value, replacement:=Rng.Offset(0, 1).Value, Lookat:=xlWhole
            End If
            End If
        Next
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub