Découper un nom de son code postal

Range("B:B,E:E,I:I,L:L,O:O,R:R").Delete Shift:=xlToLeft

Function découpe(c As String) As String
Dim s
If c Like "*(*" Then
    s = Split(c, "(")
    découpe = Trim(s(0))
End If
End Function

Option Base 1
Sub Decompose()
Dim T As Variant
fin = Range("c65536").End(xlUp).Row
Range(Cells(3, 5), Cells(fin, 6)).Clear
T = Range(Cells(3, 3), Cells(fin, 3)).Value
ReDim Preserve T(1 To 6, 1 To 3)
For i = LBound(T) To UBound(T)
x = Split(T(i, 1), "(")
T(i, 3) = Left(x(1), Len(x(1)) - 1)
T(i, 2) = Left((T(i, 1)), Len((T(i, 1))) - Len(x(1)) - 2)
Next i
For i = 2 To 3
 Cells(3, i + 3).Resize(UBound(T, 1)) = Application.Index(T, , i)
 Next i
End Sub

Function Commune(c As String) As String
Dim s
If c Like "*(*" Then
    s = Split(c, "(")
    Commune = Trim(s(0))
End If
End Function

Function Code_postal(c As String) As String
Dim s
If c Like "*(*" Then
    s = Split(c, "(")
    Code_postal = Replace(Trim(s(1)), ")", "")
End If
End Function

Sub Test()Dim Tablo1(), Tablo2(), I As Integer, J As Integer, K As Integer, DerLigne As Integer, DerColonne As Integer
DerColonne = Cells(2, Columns.Count).End(xlToLeft).Column
With CreateObject("vbscript.regexp")
    For K = 1 To DerColonne
        If Application.WorksheetFunction.CountBlank(Columns(K)) <> Rows.Count Then
            DerLigne = Cells(Rows.Count, K).End(xlUp).Row
            ReDim Preserve Tablo1(DerLigne + J)
            ReDim Preserve Tablo2(DerLigne + J)
            For I = 1 To DerLigne
                .Global = False
                .Pattern = "\d+?[0-9AB]\d{3}"
                If .Test(Cells(I, K)) Then
                    Tablo1(J) = .Execute(Cells(I, K))(0)
                    .Pattern = "[^(]*"
                    Tablo2(J) = Trim(.Execute(Cells(I, K))(0))
                    J = J + 1
                End If
            Next I
        End If
    Next K
End With
Cells.Clear
Range("A1:A" & J).Value = Application.Transpose(Tablo1)
Range("B1:B" & J).Value = Application.Transpose(Tablo2)
Range("A:B").Columns.AutoFit
End Sub

Sub Test()
Dim Tablo1(), Tablo2(), I As Integer, J As Integer, K As Integer, DerLigne As Integer, DerColonne As Integer
DerColonne = Cells(2, Columns.Count).End(xlToLeft).Column
With CreateObject("vbscript.regexp")
    For K = 1 To DerColonne
        If Application.WorksheetFunction.CountBlank(Columns(K)) <> Rows.Count Then
            DerLigne = Cells(Rows.Count, K).End(xlUp).Row
            ReDim Preserve Tablo1(DerLigne + J)
            ReDim Preserve Tablo2(DerLigne + J)
            For I = 1 To DerLigne
                .Pattern = "(.+)\s\((\d{5})\)"
                Set Matches = .Execute(Cells(I, K))
                If .Test(Cells(I, K)) Then
                    Tablo1(J) = Matches.Item(0).submatches(0)
                    Tablo2(J) = Matches.Item(0).submatches(1)
                    J = J + 1
                End If
            Next I
        End If
    Next K
End With
Cells.Clear
Range("A1:A" & J).Value = Application.Transpose(Tablo1)
Range("B1:B" & J).Value = Application.Transpose(Tablo2)
Range("A:B").Columns.AutoFit
End Sub

Sub Test()
Dim Tablo1(), Tablo2(), I As Integer, J As Integer, K As Integer, DerLigne As Integer, DerColonne As Integer
DerColonne = Cells(2, Columns.Count).End(xlToLeft).Column
With CreateObject("vbscript.regexp")
    For K = 1 To DerColonne
        If Application.WorksheetFunction.CountBlank(Columns(K)) <> Rows.Count Then
            DerLigne = Cells(Rows.Count, K).End(xlUp).Row
            ReDim Preserve Tablo1(DerLigne + J)
            ReDim Preserve Tablo2(DerLigne + J)
            For I = 1 To DerLigne
                .Pattern = "(.+)\s\((\d{5})\)"
                If .Test(Cells(I, K)) Then
                Set Matches = .Execute(Cells(I, K))
                    Tablo1(J) = Matches.Item(0).submatches(0)
                    Tablo2(J) = Matches.Item(0).submatches(1)
                    J = J + 1
                End If
            Next I
        End If
    Next K
End With
Cells.Clear
Range("A1:A" & J).Value = Application.Transpose(Tablo1)
Range("B1:B" & J).Value = Application.Transpose(Tablo2)
Range("A" & J \ 2 + 1 & ":B" & J).Copy Destination:=Range("C1")
Range("A" & J \ 2 + 1 & ":B" & J).Clear
Range("A:D").Columns.AutoFit
End Sub