Поиск и извлечение определенного числа из текста

Sub Izvlchislo()
    With ActiveSheet
        For i = 1 To .UsedRange.Rows.Count
            aa = Split(.Cells(i, 1), " ")
            bb = 0
            For j = LBound(aa) To UBound(aa)
                If IsNumeric(aa(j)) Then
                    If Len(aa(j)) = 4 Then bb = aa(j)
                End If
            Next
            .Cells(i, 2) = CInt(bb)
        Next
    End With
End Sub

Sub Izvlchislo()
    With ActiveSheet
        For i = 1 To .UsedRange.Rows.Count
            aa = Cells(i, 1)
            bb = ""
            For j = Len(aa) To 1 Step -1
            If Len(aa) > 4 Then
                cc = Mid(aa, j, 1)
                If cc = " " And (Len(bb) = 4 Or j < 5) Then GoTo m1
                If cc = " " And Len(bb) < 4 Then bb = ""
                If IsNumeric(cc) Then
                    bb = cc & bb
                    If Len(bb) = 4 Then .Cells(i, 2) = CInt(bb)
                End If
            End If
            Next
m1:
        Next
    End With
End Sub

Sub Izvlchislo()
    Dim Zn As String
    simvols = ".,$;:()" ' ïðè íåîáõîäèìîñòè äîïîëíèòü
    With ActiveSheet
        For i = 1 To .UsedRange.Rows.Count
            Zn = .Cells(i, 1)
            For s = 1 To Len(simvols)
                Zn = Replace(Zn, Mid(simvols, i, 1), "")
            Next
            aa = Split(Zn, " ")
            bb = 0
            For j = LBound(aa) To UBound(aa)
                If IsNumeric(aa(j)) Then
                    If Len(aa(j)) = 4 Then bb = aa(j)
                End If
            Next
            .Cells(i, 2) = CInt(bb)
        Next
    End With
End Sub

Sub bb()
Dim c As Range
With CreateObject("vbscript.regexp")
    .Global = True
    .Pattern = "\d{4}"
    On Error Resume Next
    For Each c In ActiveSheet.UsedRange.Columns(1).Cells
        With .Execute(c.Value)
            c(, 2) = .Item(.Count - 1)
            If Err Then Err.Clear: c(, 2) = 0
        End With
    Next
End With
End Sub

Sub QWERT()
Dim M()
Dim K()
Dim R, C
Dim LR
'В "I2:I9" находится список всех 8 номеров
'В столбце А обрабатываемый список
K = Range(Cells(2, 9), Cells(Cells(Rows.Count, 9).End(xlUp).Row, 9)) ' список номеров
M = Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 2)) ' общий список
For R = 1 To UBound(M)
    For C = 1 To UBound(K)
        If InStr(1, M(R, 1), K(C, 1)) > 0 Then
             M(R, 2) = K(C, 1)
             Exit For
        End If
    Next C
Next R
Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 2)) = M
End Sub

Public Function íÎòäåëà(ß÷åéêàÑòåêñòîì, Ñïðàâî÷íèê)
    For Each C In Range("i2:i9").Cells
      s = s & C.Text & "|"
    Next
    With CreateObject("vbscript.regexp"): .Global = True
        .Pattern = "(?:^|\D)(" & Left(s, Len(s) - 1) & ")(?=\D|$)"
        With .Execute(ß÷åéêàÑòåêñòîì)
            If .Count = 1 Then íÎòäåëà = .Item(0).SubMatches(0)
            If .Count > 1 Then íÎòäåëà = "#Îøèáêà"
        End With
    End With
End Function

For Each C In Справочник.Cells