Isoler une partie de texte d'une cellule avec position variable ?

Function les_nombres2(cel As String, nombre) As String
'adaptation dans une simple boucle for de la methode jumping "n" avec pattern absolu de jmfmarques
    Dim i&, n&, x$, pattern$
    'traduction:"[autre char que numerique]" & chaine numerique de n nombres fixe  & "[autre char que numerique]et le reste"
    pattern = "[!0-9]" & String(nombre, "#") & "[!0-9]*"
    cel = " " & cel  'add first space
    n = 1
    For i = n To Len(cel)
        If Mid(cel, n) Like pattern Then
            'x = x & " " & Mid(cel, n, nombre + 1): n = n + nombre + 1 'avec ponctuation
            x = x & " " & Mid(cel, n + 1, nombre): n = n + nombre  'sans ponctuation
        Else: n = n + 1
        End If
    Next
    les_nombres2 = x
End Function

Function les_nombres2(cel As String, nombre) As String
'adaptation dans une simple boucle for de la méthode jumping "n" avec pattern absolu de jmfmarques
    Dim i&, n&, x$, pattern$
    'traduction:"[autre char que numerique]" & chaine numerique de n nombres fixe  & "[autre char que numerique]et le reste"
    pattern = "[!0-9]" & String(nombre, "#") & "[!0-9]*"
    cel = " " & cel & " " 'add first space
    n = 1
    For i = n To Len(cel)
        If Mid(cel, n) Like pattern Then
            x = x & " " & Mid(cel, n, nombre + 1): n = n + nombre + 1 'avec ponctuation
            'x = x & " " & Mid(cel, n + 1, nombre): n = n + nombre  'sans ponctuation
        Else: n = n + 1
        End If
    Next
    les_nombres2 = x
End Function

Function Res(ByVal Mot As Range) As String
Dim Reg As Object
Dim Tabres() As Variant
Dim cpt As Byte: cpt = 1
Set Reg = CreateObject("vbscript.regexp")
With Reg
    .Pattern = "\d{4,5}"
    .MultiLine = True: .IgnoreCase = True: .Global = True:  'MsgBox .test(Mot.Value)
    If .test(Mot.Value) = False Then Exit Function
        If .test(Mot.Value) = True Then
            Set Matches = .Execute(Mot.Value)
            ReDim Tabres(1 To Matches.Count, 1 To 2)
                For Each Match In Matches
                        Tabres(cpt, 1) = Match.Value
                        Tabres(cpt, 2) = Match.Length
                        cpt = cpt + 1
                Next Match
        End If
End With
    For i = LBound(Tabres, 1) To UBound(Tabres, 1)
        If Tabres(i, 2) = 4 Then
            If Chaine4 = Empty Then Chaine4 = Tabres(i, 1) Else Chaine4 = Chaine4 & " / " & Tabres(i, 1)
        ElseIf Tabres(i, 2) = 5 Then
            If Chaine5 = Empty Then Chaine5 = Tabres(i, 1) Else Chaine5 = Chaine5 & " / " & Tabres(i, 1)
        End If
    Next i
If Cells(3, ActiveCell.Column) = "NCA" Then
    Res = Chaine4
ElseIf Cells(3, ActiveCell.Column) = "NCR" Then
    Res = Chaine5
End If
End Function

Function les_4_ou_5_faut_savoir(var As String, x As Long) As String
    Dim Reg As Object, matches As Object, i&, txt$
    Set Reg = CreateObject("vbscript.regexp")
    With Reg
       .pattern = "(\D{1})(\d{" & x & "})(\D{1})x?"
        .MultiLine = True: .IgnoreCase = True: .Global = True:    'MsgBox .test(Mot.Value)
        Set matches = .Execute(" " & var & " ")
        If matches.Count > 0 Then
           ' MsgBox var & vbCrLf & matches.Count & vbCrLf & matches(0)
            For i = 0 To matches.Count - 1: txt = txt & matches(i): Next
        End If
    les_4_ou_5_faut_savoir = txt

    End With
End Function

Function ResBis(ByVal Mot As Range) As String
Dim Reg As Object
Set Reg = CreateObject("vbscript.regexp")
With Reg
    .Pattern = "\d{4,5}"
    .MultiLine = True: .IgnoreCase = True: .Global = True:  'MsgBox .test(Mot.Value)
    If .test(Mot.Value) = False Then Exit Function
        If .test(Mot.Value) = True Then
            Set Matches = .Execute(Mot.Value)
                For Each Match In Matches
                    If Match.Length = 4 Then
                        If Chaine4 = Empty Then Chaine4 = Match.Value Else Chaine4 = Chaine4 & " / " & Match.Value
                    ElseIf Match.Length = 5 Then
                        If Chaine5 = Empty Then Chaine5 = Match.Value Else Chaine5 = Chaine5 & " / " & Match.Value
                    End If
                Next Match
        End If
End With
If Cells(3, ActiveCell.Column) = "NCA" Then
    ResBis = Chaine4
ElseIf Cells(3, ActiveCell.Column) = "NCR" Then
    ResBis = Chaine5
End If
End Function