suppression doublon

Sub Recap()
Dim Ligdebcopie As Long
Dim DerLig1 As Long, DerLig2 As Long, i As Long, Réf_VaR As Long, k As Integer, l As Long
Dim Chemin As String, Nom_de_ce_fichier As String
Dim Temporaire As String
Dim Coll As New Collection
Dim Doublontrouve As Boolean
Dim Element As Variant
Dim Tablo() As String
Dim Ligne As Long
Dim Trouve As Boolean
'Application.ScreenUpdating = False

Nom_de_ce_fichier = ThisWorkbook.Name
Chemin = ThisWorkbook.Path
Col = "c"
With Sheets("2012")
On Error Resume Next
For Each Cellule In .Range(Col & "2:" & Col & .Range(Col & .Rows.Count).End(xlUp).Row)
    Coll.Add Cellule & " " & Cellule.Row, CStr(Cellule) ' création d'une collection pour triuver les doublons
Next Cellule
On Error GoTo 0
Ligdebcopie = .Range("C" & Rows.Count).End(xlUp).Row + 1
End With


For j = 1 To 2
    DerLig2 = Range("C" & Rows.Count).End(xlUp).Row

    début = 1 + DerLig2
    Temporaire = "EM 141 - S " & Right("0" & CStr(j), 2) & ".xls"
    Workbooks.Open Filename:=Chemin & "\" & Temporaire

     Windows(Temporaire).Activate
    DerLig1 = Range("C" & Rows.Count).End(xlUp).Row

    'copie des dossiers sur le fichier de dossiers annuels
    
        Range("A3:Y" & DerLig1).Copy
        Windows(Nom_de_ce_fichier).Activate
        Range("A" & début).PasteSpecial
        Range("A" & début).Select
        Application.DisplayAlerts = False
        Windows(Temporaire).Close

'tri fichier dossiers annuels
'supprimer les lignes en doubles
With Sheets("2012")
For Each Cellule In .Range(Col & Ligdebcopie & ":" & Col & .Range(Col & .Rows.Count).End(xlUp).Row)
    On Error GoTo suite
    Doublontrouve = False
    Coll.Add Cellule & " " & Cellule.Row, CStr(Cellule)
    On Error GoTo 0
    If Doublontrouve = True Then
        For Each Element In Coll
            Tablo = Split(Element)
            If InStr((CStr(Cellule.Value)), Tablo(0)) > 0 Then
                Ligne = CLng(Tablo(UBound(Tablo)))
                .Rows(Ligne).Clear 'Shift:=xlDown
                Exit For
            End If
        Next Element
    End If
Next Cellule

End With

Windows(Nom_de_ce_fichier).Activate
DerLig2 = Range("g" & Rows.Count).End(xlUp).Row
Rows("3:" & DerLig2).Select
Selection.Sort Key1:=Range("g3"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
          

 Next j
 
On Error GoTo 0
Exit Sub
suite:
Doublontrouve = True
 Resume Next
End Sub

Rows(3 & ":" & [A65536].End(xlUp).Row).RowHeight = 15

Option Explicit

Const FEUILLE_RECAP As String = "2012"

Sub Recap_pmo()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim R1 As Range
Dim R2 As Range
Dim i&
Dim j&
Dim k&
Dim A$
Dim var1
Dim var2
Application.ScreenUpdating = False
Set WB1 = ThisWorkbook
Set S1 = WB1.Sheets.Add
For i& = 1 To 60
  On Error Resume Next
  Set WB2 = GetObject(WB1.Path & "\" & "EM 141 - S " & Right("0" & CStr(i&), 2) & ".xls")
  On Error GoTo 0
  If WB2 Is Nothing Then
    Err.Clear
  Else
    Set S2 = WB2.Sheets(1)
    S2.Range("A3:Y" & S2.Range("C" & Rows.Count).End(xlUp).Row).Copy
    If S1.UsedRange.Rows.Count = 1 Then
      S1.Range("A1").PasteSpecial
    Else
      S1.Range("A" & S1.UsedRange.Rows.Count + 1 & "").PasteSpecial
    End If
    Application.CutCopyMode = False
    Set S2 = Nothing
    WB2.Close
    Set WB2 = Nothing
  End If
Next i&
'--------
Set S2 = WB1.Sheets(FEUILLE_RECAP)
Set R2 = S2.Range("a1:y" & S2.Range("C" & Rows.Count).End(xlUp).Row & "")
var2 = R2
If UBound(var2, 1) = 2 Then
  S1.UsedRange.Copy
  S2.[a3].PasteSpecial
Else
  Set R1 = S1.UsedRange
  var1 = R1
  For i& = 1 To UBound(var2, 1)
    For k& = 1 To UBound(var1, 1)
      If var1(k&, 3) = var2(i&, 3) Then
        For j& = 1 To UBound(var2, 2)
          var2(i&, j&) = ""
        Next j&
        Exit For
      End If
    Next k&
  Next i&
  R2 = var2
  R1.Copy
  S2.Range("A" & S2.Range("C" & Rows.Count).End(xlUp).Row + 1).PasteSpecial
End If
Application.CutCopyMode = False
Application.DisplayAlerts = False
S1.Delete
Application.DisplayAlerts = True
'-----
S2.Activate
Set R2 = S2.Range("A1:Y" & S2.Range("C" & Rows.Count).End(xlUp).Row & "")
var2 = R2
For i& = UBound(var2, 1) To 3 Step -1
  If var2(i&, 3) = "" Then S2.Rows(i&).Delete
Next i&
S2.[a1].Select

'////////////////////////modif pour la hauteur des lignes/////////
If R2.Rows.Count > 2 Then
  Set R2 = S2.Rows("3:" & R2.Rows.Count & "")
  R2.RowHeight = 15
End If
'/////////////////////////////////////////////////////////////////

Application.ScreenUpdating = True
End Sub