XL 2016 VBA Synthèse Classeur Volumineux + Comparaison

Option Explicit
Sub transfert2()
   Dim Ws As Worksheet, Wd As Worksheet, dl As Long, Tb(), j As Long, Tmois(), i As Integer, Tres()
   Set Wd = Sheets("regroupement")
   j = Wd.Range("A" & Rows.Count).End(xlUp).Row
   Wd.Range("A2:E" & j).Clear
   For Each Ws In Worksheets
      If Ws.Name <> "regroupement" Then
         dl = Ws.Range("A" & Rows.Count).End(xlUp).Row
         j = Wd.Range("A" & Rows.Count).End(xlUp).Row + 1
         Tb = Ws.Range("A2:E" & dl).Value
         ReDim Tmois(1 To UBound(Tb), 1 To 1)
         For i = 1 To UBound(Tb)
            Tmois(i, 1) = Ws.Name
         Next i
         Tres = MergeArrayHoriz(Tmois, Tb)
         Wd.Range("A" & j).Resize(UBound(Tres, 1), UBound(Tres, 2)) = Tres
      End If
   Next Ws
   Set Wd = Nothing: Erase Tb
End Sub
Function MergeArrayHoriz(Tab1, Tab2) 'http://boisgontierjacques.free.fr/pages_site/tableaux.htm#FusionHoriz
Dim ktab1 As Boolean, ktab2 As Boolean, col1 As Long, col2 As Long, lg As Long, c As Long, k As Integer
  On Error Resume Next
  ktab1 = True: col1 = UBound(Tab1, 2): If Err > 0 Then col1 = 1: ktab1 = False
  Err = 0: ktab2 = True: col2 = UBound(Tab2, 2): If Err > 0 Then col2 = 1: ktab2 = False
  On Error GoTo 0
  Dim b(): ReDim b(1 To UBound(Tab1), 1 To col1 + col2)
  For lg = LBound(Tab1, 1) To UBound(Tab1)
    For c = 1 To col1
      If ktab1 = True Then b(lg, c) = Tab1(lg, c) Else b(lg, c) = Tab1(lg)
    Next c
  Next lg
  k = col1
  For lg = LBound(Tab2, 1) To UBound(Tab2)
    For c = 1 To col2
      If ktab2 = True Then b(lg, c + k) = Tab2(lg, c) Else b(lg, c + k) = Tab2(lg)
    Next c
  Next lg
  MergeArrayHoriz = b
End Function

'---------------------------------------------------------------------------------------
' LES 2 FICHIERS DOIVENT ÊTRE OUVERTS
' AVANT D'EXECUTER LE CODE ADAPTER LES NOMS DE FICHIERS WbVente et WbEnvoi
' CODE A METTRE DANS UN MODULE STANDARD DANS L'UN DES 2 FICHIERS
'---------------------------------------------------------------------------------------

Option Explicit
Sub Ouvre()
   Dim WbVente As Workbook, WbEnvoi As Workbook, Chemin As String, Fichier_à_ouvrir As String
   Dim Tev(), Tvt(), tv(), Dev As Object, Dvt As Object, i As Long, clé, n As Long, j As Byte

   Set Dev = CreateObject("scripting.dictionary")
   Set Dvt = CreateObject("scripting.dictionary")

   Set WbVente = Workbooks("Vente General Test V1.1.xlsm")
   Set WbEnvoi = Workbooks("Envoi General reduit V1.1.xlsm")

   Tev = WbVente.Sheets("Regroupement").Range("A1").CurrentRegion.Value2
   Tvt = WbEnvoi.Sheets("Regroupement").Range("A1").CurrentRegion.Value2

   For i = 2 To UBound(Tev)
      Dev(Tev(i, 3)) = ""   'reference sans doublon vente
   Next i

   For i = 2 To UBound(Tvt)
      Dvt(Tvt(i, 3)) = ""  'reference sans doublon envoi
   Next i

   For Each clé In Dev.keys
      For i = 0 To Dvt.Count - 1
         If Dvt.keys()(i) = clé Then
            Dvt.Remove (clé)   'on vire reference existantes
            Exit For
         End If
      Next i
   Next

   n = 0
   For Each clé In Dvt.keys
      For i = 1 To UBound(Tvt, 1)
         If Tvt(i, 3) = clé Then
            n = n + 1
            ReDim Preserve tv(1 To 6, 1 To n)
            For j = 1 To 6
               tv(j, n) = Tvt(i, j)   ' on alimente tableau des clées restantes
            Next j
         End If
      Next i
   Next

   With WbEnvoi.Sheets("Control")
      .Cells.Clear
      Sheets("Regroupement").Range("A1:F1").Copy .Range("A1")
      .Range("A2").Resize(UBound(tv, 2), UBound(tv, 1)) = Application.Transpose(tv)
      .Range("E2").Resize(UBound(tv, 2), 1).NumberFormat = "m/d/yyyy"
   End With

  ' on refait la même chose pour le fichier vente
   'on réalimente le dictionnaire reference vente
   For i = 2 To UBound(Tvt)
      Dvt(Tvt(i, 3)) = ""  'reference sans doublon envoi
   Next i
''****************************************************************
   For Each clé In Dvt.keys
Debug.Print clé
      For i = 0 To Dev.Count - 1
Debug.Print Dev.keys()(i)
         If Dev.keys()(i) = clé Then
            Dev.Remove (clé)   'on vire reference existantes
            Exit For
         End If
      Next i
   Next

   n = 0
   For Each clé In Dev.keys
      For i = 1 To UBound(Tev, 1)
         If Tev(i, 3) = clé Then
            n = n + 1
            ReDim Preserve tv(1 To 6, 1 To n)
            For j = 1 To 6
               tv(j, n) = Tev(i, j)   ' on alimente tableau des clées restantes
            Next j
         End If
      Next i
   Next

   With WbVente.Sheets("Control")
      .Cells.Clear
      Sheets("Regroupement").Range("A1:F1").Copy .Range("A1")
      .Range("A2").Resize(UBound(tv, 2), UBound(tv, 1)) = Application.Transpose(tv)
      .Range("E2").Resize(UBound(tv, 2), 1).NumberFormat = "m/d/yyyy"
   End With

   Set WbVente = Nothing: Set WbEnvoi = Nothing: Set Dev = Nothing: Set Dvt = Nothing
End Sub