Sub D()
     Dim cell As Range
     For Each cell In [A:A]
         If cell.Value = "" Then Exit Sub
         txt = CStr(cell.Value)
         For i = 1 To Len(txt)
             If Val(Mid(txt, i, 1)) > 0 Then
                 cell.Offset(, 1).Value = Mid(txt, i)
                 Exit For
             End If
         Next i
     Next cell
End Sub

Sub Мяу()
Dim arr(), i&
' для скорости работаем с массивом
arr() = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
' перебираем элементы массива
For i = 1 To UBound(arr)
' меняем все пробелы и тире на "пусто"
arr(i, 1) = Replace(arr(i, 1), " ", "")
arr(i, 1) = Replace(arr(i, 1), "-", "")
arr(i, 1) = Replace(arr(i, 1), Chr(160), "") ' на всякий случай, вдруг неразрывный пробел попадется
' извлекаем число
arr(i, 1) = Val(arr(i, 1))
'arr(i, 1) = "'" & Val(arr(i, 1)) ' если нужен текст
Next
' выгружаем на лист
Range("D1").Resize(UBound(arr)) = arr
End Sub

Sub D()
     ' Определяем переменную для удобства
     Dim cell As Range
     ' Начинаем перебор по столбику А
     ' Если нужно перебрать какой-то диапазон ячеек, то можно написать Лист1.Range("A1","B10")
     ' будет перебор диапазона ячеек "A1:B10"
     For Each cell In [A:A]
         ' Если очередная ячейка пустая, то заканчиваем работу - дошли до конца заполненных ячеек
         If cell.Value = "" Then Exit Sub
         ' Переносим значение очередной ячейки в переменную txt
         ' Для надежности конвертируем содержимое в текст - CStr. Если будет число, то оно тоже попадет как текст
         txt = CStr(cell.Value)
         ' Начинаем перебор от 1 до длины строки в txt
         For i = 1 To Len(txt)
             ' Получаем очередную букву Mid(txt, i, 1) - см. описание в интернет
             ' Переводим букву в число с помощью функции Val. Все что не число переведется в 0
             If Val(Mid(txt, i, 1)) > 0 Then
                 ' Если буква оказалось числом (одно из 123456789)
                 ' Копируем значения в ячейку справа .Offset(, 1) оставшиеся значения до конца (с позиции = i) Mid(txt, i)
                 cell.Offset(, 1).Value = Mid(txt, i)
                 ' Выходим из цикла перебора
                 Exit For
             End If
             ' Идем на следующую букву строки в txt
         Next i
     ' Идем на следующую ячейку перебора по столбику А
     Next cell
End Sub

    Dim arr(), i&
       ' для скорости работаем с массивом
       arr() = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
       ' перебираем элементы массива
       For i = 1 To UBound(arr)
          ' Ищем позицию "-" справа
           p = InStrRev(arr(i, 1), "-")  
          ' Если нашли, то берем то что слева
           If p > 0 Then arr(i, 1) = Mid(arr(i, 1), p+1)
            ' меняем все пробелы и тире на "пусто"
           arr(i, 1) = Replace(arr(i, 1), " ", "")
           arr(i, 1) = Replace(arr(i, 1), Chr(160), "") ' на всякий случай, вдруг неразрывный пробел попадется
           ' извлекаем число
           arr(i, 1) = Val(arr(i, 1))
           ' Если значение =0 , присваиваем значение "ничто"
           If arr(i, 1) = 0 Then arr(i, 1) = Null
           'arr(i, 1) = "'" & Val(arr(i, 1)) ' если нужен текст
       Next
       ' выгружаем на лист
       Range("D1").Resize(UBound(arr)) = arr

Sub Мяв()
      Dim arr(), i&, s
      ' для скорости работаем с массивом
      arr() = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row).Value
      'On Error Resume Next
      ' перебираем элементы массива
      For i = 1 To UBound(arr)
          If Not IsEmpty(arr(i, 1)) Then ' пустые пропускаем
              If Asc(Left$(arr(i, 1), 1)) < 58 Then ' проверяем, в ячейке номер, или надпись
                  ' меняем все пробелы и тире на "пусто"
                  arr(i, 1) = Replace(arr(i, 1), " ", "")
                  arr(i, 1) = Replace(arr(i, 1), Chr(160), "")    ' на всякий случай, вдруг неразрывный пробел попадется
                  s = Split(arr(i, 1), "-") ' делим на части по "-"
                  ' извлекаем число
                  arr(i, 1) = Val(s(UBound(s))) ' берем последнюю часть
                  'arr(i, 1) = "'" & Val(arr(i, 1)) ' если нужен текст
              End If
          End If
      Next
      ' выгружаем на лист
      Range("I1").Resize(UBound(arr)) = arr
End Sub

Sub F()
      With Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
          .NumberFormat = "general"
          .Replace " ", Empty, xlPart
          .Replace "*-", Empty, xlPart
          .Formula = .Value
      End With
End Sub

Sub upd()
     Dim arr() As Variant
     With Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row)
         arr = .Value
         With Intersect(.EntireRow, [I:I])
             .NumberFormat = "general"
             .Formula = arr
             .Replace " ", Empty, xlPart
             .Replace "*-", Empty, xlPart
         End With
     End With
End Sub