Rechercher des données dans un tableau à partir d'un autre

Option Explicit  
Option Base 1  
Dim T_base, T_zus  

Sub selectionner_habitants()  
Dim T_ame()  
Dim Cptr As Integer, Lig As Integer, Col As Byte, Cpt As Integer, chmp As Byte  
     Application.ScreenUpdating = False  
     Call harmoniser_ecritures  
     ReDim T_ame(7, 1)  
       
     For Cptr = 1 To UBound(T_zus)  
          For Lig = 1 To UBound(T_base)  
               For Col = 2 To 4  
                    If InStr(T_base(Lig, Col), T_zus(Cptr, 1)) Then  
                         Cpt = Cpt + 1  
                         ReDim Preserve T_ame(7, Cpt)  
                         For chmp = 1 To 7  
                              T_ame(chmp, Cpt) = T_base(Lig, chmp)  
                         Next chmp  
                         Exit For  
                    End If  
               Next Col  
          Next Lig  
     Next Cptr  
       
     With Sheets(3)  
          With .Range("A2:G" & Cpt)  
               .Value = Application.Transpose(T_ame)  
               .Borders.Weight = xlThin  
          End With  
          .Select  
     End With  
End Sub  

Sub harmoniser_ecritures()  
Dim derlig As Integer, Lig As Integer, Col As Byte  
Dim zus As String  

With Sheets(1)  
     derlig = .Columns("A").Find("*", , , , , xlPrevious).Row  
     T_base = .Range("A2:G" & derlig).Value  
     For Lig = 1 To derlig - 1  
          For Col = 1 To 3  
               T_base(Lig, Col) = UCase(Trim(T_base(Lig, Col)))  
          Next Col  
     Next Lig  
End With  

With Sheets("zus")  
     derlig = .Columns("A").Find("*", , , , , xlPrevious).Row  
     T_zus = .Range("A2:A" & derlig).Value  
     For Lig = 1 To derlig - 1  
          zus = T_zus(Lig, 1)  
          T_zus(Lig, 1) = UCase(Trim(enlever_accents(zus)))  
     Next  
End With  
End Sub  

Function enlever_accents(texto As String) As String  
Dim accents As String * 14, caract As String * 1, lettre As String * 1  
Dim Cptr As Integer, pos As Integer  

     accents = "âäàêëéèîïôöûüù"  
     For Cptr = 1 To Len(texto)  
          caract = Mid(texto, Cptr, 1)  
           pos = InStr(accents, caract)  
           If pos > 0 Then  
               lettre = Choose(pos, "a", "a", "a", "e", "e", "e", "e", "i", "i", "o", "o", "u", "u", "u")  
                texto = Replace(texto, caract, lettre)  
          End If  
     Next  
     enlever_accents = texto  
End Function