Formule rechercheV buggée et run macro très long

Sub CommunsTot()
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  Set f3 = Sheets("Communs2")
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("a2:a" & f1.[a65000].End(xlUp).Row)   ' adapter
    mondico1(UCase(sansAccent(c.Value))) = c.Row
  Next c
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For Each c In f2.Range("a2:a" & f2.[a65000].End(xlUp).Row)   ' adapter
    tmp = UCase(sansAccent(c.Value))
    If mondico1.exists(tmp) Then If Not mondico2.exists(tmp) Then mondico2(tmp) = c.Row
  Next c
  f3.[A2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.keys)
  col1 = f1.[A1].CurrentRegion.Columns.Count     ' adapter
  col2 = f2.[A1].CurrentRegion.Columns.Count     ' adapter
  lig = 2
  For Each c In mondico2
    f1.Cells(mondico1(c), 1).Resize(, col1).Copy f3.Cells(lig, 2)
    f2.Cells(mondico2(c), 1).Resize(, col2).Copy f3.Cells(lig, col1 + 2)
    lig = lig + 1
  Next c
End Sub