Fusion plusieurs feuilles

Sub Synthèse()
Dim w As Worksheet, i As Long, j As Long, txt As String
With Sheets("Récap.")
.[A2:C65536].Clear 'efface tout dans la zone de recopie
Application.ScreenUpdating = False 'fige l'écran

'---Copie des feuilles---
For Each w In Worksheets
  If w.Name <> .Name Then _
    w.Range("A2:C" & w.[A65536].End(xlUp).Row).Copy .[A65536].End(xlUp)(2)
Next

'---Elimination des doublons---
For i = .[A65536].End(xlUp).Row To 3 Step -1
  txt = UCase(.Cells(i, 1) & .Cells(i, 2))
  For j = i - 1 To 2 Step -1
    If txt = UCase(.Cells(j, 1) & .Cells(j, 2)) Then 'compare les textes mis en majuscules
      .Cells(j, 3) = .Cells(j, 3) + .Cells(i, 3) 'additionne les valeurs
      .Rows(i).Delete 'supprime la ligne
      Exit For
    End If
  Next
Next

.[A2:C65536].Sort Key1:=.[A2], Order1:=xlAscending, _
  Key2:=.[B2], Order2:=xlAscending, Header:=xlNo 'trie sur 2 colonnes
End With
End Sub

Sub FusionConsoRapide()
  [A2:C1000].ClearContents
  Application.ScreenUpdating = False
  For s = 2 To Sheets.Count
     Range(Sheets(s).[A2], Sheets(s).[A65000].End(xlUp).End(xlToRight)).Copy [A65000].End(xlUp).Offset(1, 0)
  Next s
  [A1:C1000].Sort Key1:=[A2], Order1:=xlAscending, Key2:=[B2], Order2:=xlAscending, Header:=xlGuess
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 2 To [A65000].End(xlUp).Row
    temp = Cells(i, "A") & "_" & Cells(i, "B")
    mondico(temp) = mondico(temp) + Cells(i, "C")
  Next
  [A2:C1000].ClearContents
  [A2].Resize(mondico.Count) = Application.Transpose(mondico.keys)
  [C2].Resize(mondico.Count) = Application.Transpose(mondico.items)
  Application.DisplayAlerts = False
  [A2:A1000].TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="_"
End Sub