Double Comparaison colonne

Option Explicit

Sub Compare2colonnes()
Dim SheetRestiBdd As Worksheet, SheetRestiExtr As Worksheet
Dim T_In_Extract(), T_In_Bdd(), T_Out_Extract(), T_Out_Bdd()
Dim Entete_Cols_Extr(), Entete_Cols_Bdd()
Dim Dico_Extract As Object, Dico_Bdd As Object
Dim DLig As Long, DLigTemp As Long, i As Long, Ligne As Long, Cpt_Out_Ectract As Long, Cpt_Out_Bdd As Long
Dim Nb_Col As Integer, j As Integer

   '---------------------------------
   'A ADAPTER :
   Const NOM_FEUIL_EXTRACT As String = "Extraction"
   Const NOM_FEUIL_BDD As String = "Base de donnée"
   Const AJOUT_FEUIL_EXTRACT As String = "Extraction apres macro"
   Const AJOUT_FEUIL_BDD As String = "Bdd apres macro"
   Const NUM_LIGN_DEBUT As Integer = 2
   Const LETTRE_DERNIERE_COLONNE As String = "P"
   '---------------------------------
   
   '---------------------------------
   'Lignes à supprimer après tests
   Dim t As Single
   t = Timer
   '---------------------------------
   
   'création des 2 feuilles de restitution des données
   If Not Feuil_Exist(ThisWorkbook.Name, AJOUT_FEUIL_BDD) Then
      Sheets.Add After:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = AJOUT_FEUIL_BDD
   End If
   If Not Feuil_Exist(ThisWorkbook.Name, AJOUT_FEUIL_EXTRACT) Then
      Sheets.Add After:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = AJOUT_FEUIL_EXTRACT
   End If
   
   'Initialisation des variables
   Nb_Col = Asc(LETTRE_DERNIERE_COLONNE) - Asc("A") + 1
   Set Dico_Bdd = CreateObject("Scripting.Dictionary")
   Set Dico_Extract = CreateObject("Scripting.Dictionary")
   Set SheetRestiExtr = Sheets(AJOUT_FEUIL_EXTRACT)
   Set SheetRestiBdd = Sheets(AJOUT_FEUIL_BDD)
   
   'Enregistrement, en mémoire, des données des deux feuilles
   With Sheets(NOM_FEUIL_EXTRACT)
      DLig = .Columns(2).Find("*", , , , xlByColumns, xlPrevious).Row
      DLigTemp = .Columns(13).Find("*", , , , xlByColumns, xlPrevious).Row
      If DLigTemp > DLig Then DLig = DLigTemp
      T_In_Extract = .Range("A" & NUM_LIGN_DEBUT & ":" & LETTRE_DERNIERE_COLONNE & DLig).Value
      Entete_Cols_Extr = .Range("A1:" & LETTRE_DERNIERE_COLONNE & "1").Value
   End With
   With Sheets(NOM_FEUIL_BDD)
      DLig = .Columns(2).Find("*", , , , xlByColumns, xlPrevious).Row
      DLigTemp = .Columns(13).Find("*", , , , xlByColumns, xlPrevious).Row
      If DLigTemp > DLig Then DLig = DLigTemp
      T_In_Bdd = .Range("A" & NUM_LIGN_DEBUT & ":" & LETTRE_DERNIERE_COLONNE & DLig).Value
      Entete_Cols_Bdd = .Range("A1:" & LETTRE_DERNIERE_COLONNE & "1").Value
   End With
   
   'stockage des éléments des colonnes B(2) et M(13) + début traitement
   For i = LBound(T_In_Extract) To UBound(T_In_Extract)
      T_In_Extract(i, 13) = "'" & T_In_Extract(i, 13)
      Dico_Extract(T_In_Extract(i, 2)) = T_In_Extract(i, 13)
   Next i
   For i = LBound(T_In_Bdd) To UBound(T_In_Bdd)
      T_In_Bdd(i, 13) = "'" & T_In_Bdd(i, 13)
      Dico_Bdd(T_In_Bdd(i, 2)) = T_In_Bdd(i, 13)
      'début traitement
      If Dico_Extract.exists(T_In_Bdd(i, 2)) And Dico_Extract(T_In_Bdd(i, 2)) <> T_In_Bdd(i, 13) Then
      Else
         Cpt_Out_Bdd = Cpt_Out_Bdd + 1
         ReDim Preserve T_Out_Bdd(1 To Nb_Col, 1 To i)
         For j = 1 To Nb_Col
            T_Out_Bdd(j, Cpt_Out_Bdd) = T_In_Bdd(i, j)
         Next j
      End If
   Next i
   
   'fin traitement
   For i = LBound(T_In_Extract) To UBound(T_In_Extract)
      If Dico_Bdd.exists(T_In_Extract(i, 2)) And Dico_Bdd(T_In_Extract(i, 2)) = T_In_Extract(i, 13) Then
      Else
         Cpt_Out_Ectract = Cpt_Out_Ectract + 1
         ReDim Preserve T_Out_Extract(1 To Nb_Col, 1 To i)
         For j = 1 To Nb_Col
            T_Out_Extract(j, Cpt_Out_Ectract) = T_In_Extract(i, j)
         Next j
      End If
   Next i
   
   'restitution des données en feuilles "extract apres macro" et "bdd apres macro"
   With SheetRestiBdd
      .Cells.ClearContents
      .Range("A1").Resize(, UBound(Entete_Cols_Bdd, 2)) = Entete_Cols_Bdd
      .Range("A2").Resize(UBound(T_Out_Bdd, 2), UBound(T_Out_Bdd, 1)) = Application.Transpose(T_Out_Bdd)
   End With
   With SheetRestiExtr
      .Cells.ClearContents
      .Range("A1").Resize(, UBound(Entete_Cols_Extr, 2)) = Entete_Cols_Extr
      .Range("A2").Resize(UBound(T_Out_Extract, 2), UBound(T_Out_Extract, 1)) = Application.Transpose(T_Out_Extract)
   End With
   
   'Ligne à supprimer après tests
   MsgBox Timer - t & " secondes"
End Sub

Function Feuil_Exist(strWbk As String, strWsh As String) As Boolean
'Gestionnaire d'erreur
On Error Resume Next
    '"Test"
    Feuil_Exist = (Workbooks(strWbk).Sheets(strWsh).Name = strWsh)
End Function