comparaison des feuilles

Sub Communs()
Dim lig As Integer, cel As Range, i As Integer
[COLOR="Red"]Sheets(1).Range("C2:D65536").ClearContents[/COLOR]
lig = 1
For Each cel In Sheets(2).Range("A2", Sheets(2).Range("A65536").End(xlUp))
  For i = 3 To Sheets.Count
    If Application.CountIf(Sheets(i).Range("A2", Sheets(i).Range("A65536").End(xlUp)), cel) = 0 Then GoTo 1
  Next
  lig = lig + 1
  Sheets(1).Cells(lig, 3) = cel
  Sheets(1).Cells(lig, 4) = cel.Offset(, 1)
1 Next
End Sub

Sub Communs()
Dim Nom As String, lig As Integer, N As Byte, cel As Range, ws As Worksheet
[COLOR="Red"]Nom = "compara" 'feuille d'étude[/COLOR]
On Error Resume Next 'au cas où "compara" n'existe pas
Worksheets(Nom).Range("C2:D65536").ClearContents
If Err Then MsgBox "La feuille d'étude doit être nommée """ & Nom & """...", 48: Exit Sub
lig = 1
[COLOR="Red"]N = IIf(Worksheets(1).Name <> Nom, 1, 2) 'position de la feuille de référence[/COLOR]
For Each cel In Worksheets(N).Range("A2", Worksheets(N).Range("A65536").End(xlUp))
  For Each ws In Worksheets
    If ws.Name <> Nom Then
      If Application.CountIf(ws.Range("A:A"), cel) = 0 Then GoTo 1
    End If
  Next
  lig = lig + 1
  Sheets(Nom).Cells(lig, 3) = cel
  Sheets(Nom).Cells(lig, 4) = cel.Offset(, 1)
1 Next
End Sub

Sub communs()
  Set f1 = Sheets("10")
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("a2:a" & f1.[a65000].End(xlUp).Row)
     mondico1.Item(c.Value) = c.Offset(, 1).Value
  Next
  For Each f In Array("15", "18", "12")
    Set mondico2 = CreateObject("Scripting.Dictionary")
    For Each c In Sheets(f).Range("a2:a" & Sheets(f).[a65000].End(xlUp).Row)
      If mondico1.Exists(c.Value) Then mondico2(c.Value) = c.Offset(, 1).Value
    Next c
    Set mondico1 = mondico2
  Next f
  Sheets("communs").[c2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.keys)
  Sheets("communs").[d2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
End Sub