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