XL 2013 code temps exécution long

Sub Rechercher()
Dim F As Worksheet, d As Object, tablo, i&, resu(), n&, j%
Set F = Feuil4 'CodeName de la feuille de destination
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
'---liste des villes à rechercher---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignoré
tablo = F.Range("B1", F.Range("B" & F.Rows.Count).End(xlUp)(2)) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
If tablo(i, 1) <> "" Then d(tablo(i, 1)) = ""
Next
'---analyse du tableau source---
tablo = Feuil1.UsedRange.Columns("A:T") 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 19) 'tableau pour les résultats
For i = 1 To UBound(tablo)
    If d.exists(tablo(i, 3)) Then
        n = n + 1
        For j = 1 To 19: resu(n, j) = tablo(i, j + 1): Next
    End If
Next
'---restitution---
If n Then
    F.[D2].Resize(n, 19) = resu
    F.[D2].Resize(n, 19).Borders.Weight = xlHairline 'bordures
End If
F.Range("D" & n + 2 & ":V" & F.Rows.Count).Delete xlUp 'RAZ en dessous
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
End Sub

Sub ModifNomsCommunes()
   Dim c As Range, Sh As Worksheet
   Set Sh = Sheets("vérifie secteur")
   For Each c In Sh.Range("w3:w" & Sh.Range("w" & Rows.Count).End(xlUp).Row)
      c = Sans_accents(c)
   Next
End Sub

Function Sans_accents(chaine As Range)
   Dim T As String, A As String, B As String
   Dim i As Integer, U As String
   If chaine.Value = "" Then Exit Function
   T = chaine.Value
   'remplacement des caractères accentués
   A = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåèéêëìíîïðñòóôõöùúûüýÿçÇ"
   B = "AAAAAAEEEEIIIINOOOOOUUUUYaaaaaaeeeeiiiionooooouuuuyycC"
   For i = 1 To Len(T)
      U = InStr(1, A, Mid(T, i, 1), 0)
      If U Then Mid(T, i, 1) = Mid(B, U, 1)
   Next i
   Sans_accents = T
End Function

Sub Rechercher()
Dim F As Worksheet, d As Object, tablo, i&, source, resu(), lig&, n&, j%
Set F = Feuil4 'CodeName de la feuille de destination
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
F.[C:C].ClearContents 'effacement des repères en colonne C
'---liste des villes à rechercher---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignoré
tablo = F.Range("B1:C" & F.Range("B" & F.Rows.Count).End(xlUp).Row)  'matrice, plus rapides
For i = 2 To UBound(tablo)
If tablo(i, 1) <> "" Then d(tablo(i, 1)) = i 'repère la ligne
Next
'---analyse du tableau source---
source = Feuil1.UsedRange.Columns("A:T") 'matrice, plus rapide
ReDim resu(1 To UBound(source), 1 To 19) 'tableau pour les résultats
For i = 1 To UBound(source)
    lig = d(source(i, 3))
    If lig Then
        n = n + 1
        For j = 1 To 19: resu(n, j) = source(i, j + 1): Next
        tablo(lig, 2) = " " 'repère invisible en colonne C
    End If
Next
'---restitution---
If n Then
    F.[C1].Resize(UBound(tablo)) = Application.Index(tablo, , 2)
    F.[D2].Resize(n, 19) = resu
    F.[D2].Resize(n, 19).Borders.Weight = xlHairline 'bordures
End If
F.Range("D" & n + 2 & ":V" & F.Rows.Count).Delete xlUp 'RAZ en dessous
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
End Sub