' Sub ExtractNumbersFromString() Application.ScreenUpdating = False Dim rng As Range Dim uColumn As String For Each rng In Selection uColumn = Replace(Cells(1, rng.Column).Address(0, 0), 1, "") Dim i As Long, j As Long, r As Range For i = 0 To Range(uColumn & Rows.Count).End(xlUp).Row Set r = Range(uColumn & i + 1) Dim tmpStr As String tmpStr = vbNullString For j = 1 To Len(r) If IsNumeric(Right(Left(r, j), 1)) Then tmpStr = tmpStr & Right(Left(r, j), 1) Next j r.NumberFormat = "@" r = tmpStr Next i Next rng Set rng = Nothing Application.ScreenUpdating = True End Sub '