Gestion automatique du nom des rues écrit sous la forme : Cauquène (allée de).

Function Renverse(Target As Range) As String[INDENT]Renverse = StrReverse(Target)[/INDENT]
End Function

=DROITE(C6;TROUVE(CAR(32);Renverse(C6))-1)& " (" &GAUCHE(C6;TROUVE(DROITE(C6;TROUVE(CAR(32);Renverse(C6))-1);C6)-1)&")"

With Range("B5")
        a = Range(.Cells, Cells(Rows.Count, .Column).End(xlUp)).Value
    End With

Function Glossaire(c As String) As String
Dim oRegExp As Object, matches As Object
Set oRegExp = CreateObject("vbscript.regexp")
With oRegExp
    .Global = True
    .Pattern = ".*((?:AVENUE|BOULEVARD|COURS|PLACE|PROMENADE|RUE|ROUTE|CARREFOUR|CHEMIN|ESPLANADE|IMPASSE|QUAI|RUELLE|ROND-POINT|VOIE|Z.A.C.|Z.I.)\s+(?:AUX |D'|DE (?:LA |L')?|DES )?)(.*)"
    If .test(c) = True Then Glossaire = .Replace(c, "$2 ($1)")
End With
Set oRegExp = Nothing: Set matches = Nothing
End Function

Sub tata()
Dim i&, j&, tmp$, a(), b()
P1: With Feuil2.Range("A1")
        b = .Parent.Range(.Offset(0, 2).Cells, .Parent.Cells(.Parent.Rows.Count, .Offset(0, 2).Column).End(xlUp).Offset(1)).Value
    End With
    b(UBound(b), 1) = " "
P2: With Feuil1.Range("B5")
        a = .Parent.Range(.Cells, .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp)).Value
    End With
    ReDim Preserve a(1 To UBound(a), 1 To 2)
    For i = 2 To UBound(a)
        tmp = UCase(WorksheetFunction.Trim(a(i, 1)))
        For j = 1 To UBound(b)
            If InStr(1, tmp, UCase(b(j, 1))) Then
                a(i, 2) = Right$(tmp, Len(tmp) - Len(b(j, 1))) & " (" & UCase(Trim(b(j, 1))) & ")"
                Exit For
            End If
        Next
    Next
P3: With Feuil1.Range("AI5")
        .Resize(UBound(a), 2).Value = a
    End With
End Sub

Sub toto()
Dim i&, j&, k&, tmp$, a(), b()
P1: With Feuil2.Range("A1")
        a = .Parent.Range(.Cells, .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp)).Value
        With .Offset(0, 1)
            b = .Parent.Range(.Cells, .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Offset(1)).Value
        End With
        b(UBound(b), 1) = " "
        With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
        With .Offset(0, 2)
            .Parent.Columns(.Column).Resize(.Parent.Rows.Count - .Row + 1, 1).Offset(.Row - 1).ClearContents
            For i = 1 To UBound(a)
                tmp = a(i, 1)
                For j = 1 To UBound(b)
                    .Offset(k).Value = tmp & b(j, 1)
                    k = k + 1
                Next
            Next
        End With
        With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
    End With
End Sub

P3: With Feuil1.Range("AI5")

P3: With Sheets("Résultat").Range("D8")

Sub tutu()
Dim i&, j&, tmp$, a(), b()
P1: b = paramètres(Feuil2.Range("A1"))
P2: With Feuil1.Range("B5")
        a = .Parent.Range(.Cells, .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp)).Value
    End With
    ReDim Preserve a(1 To UBound(a), 1 To 2)
    For i = 2 To UBound(a)
        tmp = UCase(WorksheetFunction.Trim(a(i, 1)))
        For j = 1 To UBound(b)
            If InStr(1, tmp, UCase(b(j))) Then
                a(i, 2) = Right$(tmp, Len(tmp) - Len(b(j))) & " (" & UCase(Trim(b(j))) & ")"
                Exit For
            End If
        Next
    Next
P3: With Feuil1.Range("AI5")
        .Resize(UBound(a), 2).Value = a
    End With
End Sub

Private Function paramètres(RData As Range)
Dim i&, j&, k&, tmp$, a(), b(), c()
    With RData
        a = .Parent.Range(.Cells, .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp)).Value
        With .Offset(0, 1)
            b = .Parent.Range(.Cells, .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Offset(1)).Value
        End With
        b(UBound(b), 1) = " "
        ReDim c(1 To UBound(a) * UBound(b))
        With .Offset(0, 2)
            For i = 1 To UBound(a)
                tmp = a(i, 1)
                For j = 1 To UBound(b)
                    k = k + 1
                    c(k) = tmp & b(j, 1)
                Next
            Next
        End With
    End With
    paramètres = c
End Function

Function Glossaire(c As String) As String
Dim oRegExp As New RegExp
c = Trim(c)
With oRegExp
    .Global = True
    .IgnoreCase = True
    .Pattern = "\s{2,}"
    If .Test(c) = True Then c = .Replace(c, " ")
    .Pattern = ".*((?:AVENUE|BOULEVARD|COURS|PASSAGE|PLACE|PROMENADE|RUE|ROUTE|CARREFOUR|CHEMIN|ESPLANADE|IMPASSE|QUAI|RUELLE|ROND-POINT|VOIE|Z.A.C.|Z.I.)\s+(?:AU |AUX |À (?:L')?|D'|DU |DE (?:LA |L')?|DES )?)(.*)"
    If .Test(c) = True Then Glossaire = Replace(.Replace(c, "$2 ($1)"), " )", ")")
End With
Set oRegExp = Nothing
End Function

Function Glossaire(c As String) As String 'Version 3
Dim oRegExp As New RegExp
c = Trim(c)
With oRegExp
    .Global = True
    .IgnoreCase = True
    .Pattern = "\s{2,}"
    If .Test(c) = True Then c = .Replace(c, " ")
    .Pattern = ".*\b((?:AVENUE|BOULEVARD|COURS|PASSAGE|PLACE|PROMENADE|RUE|(?:AUTO)?ROUTE|CARREFOUR|CHEMIN|ESPLANADE|IMPASSE|PONT|QUAI|RUELLE|ROND(?:-|\s)POINT|VOIE|Z.A.C.|Z.I.)\s+(?:AU |AUX |À (?:L')?|D'|DU |DE (?:LA |L')?|DES )?)(.*)"
    If .Test(c) = True Then Glossaire = Replace(.Replace(c, "$2 ($1)"), " )", ")")
End With
Set oRegExp = Nothing
End Function