Supprimer lettres et laisser chiffres

Sub essai()
Dim val1 As String
Dim i As Long
For i = 1 To Len(ActiveCell)
    If Asc(Mid(ActiveCell, i, 1)) > 47 And Asc(Mid(ActiveCell, i, 1)) < 59 Then val1 = val1 & Mid(ActiveCell, i, 1)
Next
ActiveCell = val1
End Sub

Sub essai()
Dim val1 As String
Dim i As Long
Dim cell As Range
Dim oldCalculation As Variant '
Dim reponse As Variant

oldCalculation = Application.Calculation
Application.Calculation = xlCalculationManual

'expression.InputBox(Prompt, Title, Default, Left, Top, HelpFile, HelpContextId, Type)
On Error GoTo suite
Set reponse = Application.InputBox(Prompt:="Veuillez sélectionner la zone à convertir", Type:=8, Default:="")

Application.ScreenUpdating = False 'gele l'ecran
Application.EnableEvents = False
Application.DisplayAlerts = False 'interdit les messages d'avertissements

For Each cell In reponse
    If cell = "" Then
    Else
        val1 = ""
        For i = 1 To Len(cell)
            If Asc(Mid(cell, i, 1)) > 47 And Asc(Mid(cell, i, 1)) < 59 Then val1 = val1 & Mid(cell, i, 1)
        Next
        cell = val1
    End If
Next cell
fin:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = oldCalculation
'Application.DisplayAlerts = True ' par défaut
Exit Sub
suite:
Resume fin
End Sub