Extraire les différences entre 2 feuilles (Solutionné)

[Ghost]

Bonjour à tous,
Depuis quelques mois je planche sur un problème dont je n'ai qu'une solution partielle actuellement.

Je cherche à comparer 2 tableaux que je crée à partir de l'extration d'un logiciel (Actuellement environ 250 à 300 lignes, et bientôt entre 500 et 600 lignes à comparer)

Voici les données extraites (en ligne)

• Nom
• Prénom
• Lieu
• Date et heure d'arrivée
• Date et heure de départ

Mon souci est que je crée un prévisionnel à partir d'une extraction et la semaine suivante je dois refaire une extraction et voir toutes les différences pour apporter les correction en fonction, s'il y a un changement dans les personnes lieu date ou heure (voir tout à la fois)

J'ai obtenu une solution partielle grâce à au code ci dessous, qui me permet d'afficher les différences entre les tableaux, ligne par ligne:

Private Sub ComparaisonTableau_Click()

 Dim RG1 As Range, RG2 As Range
 Dim Tblo1, Tblo2, Rg3 As Range
 Dim A As Long, B As Integer, C As Long, D As Integer
 
 Set RG1 = Sheets("Prevision").Range("B4:F999") 'Tabeau 1
 Set RG2 = Sheets("Reel").Range("B2:F997") 'Tableau 2
 Set Rg3 = Sheets("Différence").Range("B4") 'Tableau des résultats
 
 Sheets("Différence").Range("B4:E1000").ClearContents
 
 If RG1.Rows.Count <> RG2.Rows.Count Then
  MsgBox "Le tableau n'a pas le même nombre de lignes"
  Exit Sub
 End If
 If RG1.Columns.Count <> RG2.Columns.Count Then
   MsgBox "Le tableau n'a pas le même nombre de colonnes"
  Exit Sub
 End If
  
 Tblo1 = RG1: Tblo2 = RG2: D = 1
 Application.ScreenUpdating = False
 For A = 1 To UBound(Tblo1, 1)
  For B = 1 To UBound(Tblo1, 2)
    If Tblo1(A, B) <> Tblo2(A, B) Then
      C = C + 1
      Rg3(C, D) = RG1(A, B).Address(0, 0)
      Rg3(C, D).Offset(, 1) = Tblo1(A, B)
      Rg3(C, D).Offset(, 2) = RG2(A, B).Address(0, 0)
      Rg3(C, D).Offset(, 3) = Tblo2(A, B)
    End If
  Next
 Next
 
 Set RG1 = Nothing: Set RG2 = Nothing: Set Rg3 = Nothing
 Erase Tblo1: Erase Tblo2

End Sub

Les problèmes commencent dès que l'on a une à plusieurs lignes qui s'intercallent dans le tableau ou se soustraient dans le tableau par rapport à la feuilles de référence (ou vice versa), car dans ces cas là, il m'affiche l'intégralité des données qui suivent ce changement, alors que je n'aurais besoin de savoir que seul cette ou ces lignes sont disparues ou sont apparues en plus des autre modification qui se trouvent actuellement noyé au milieu du reste.

J'ai surligné dans les fichiers en pièce jointe les modifications en jaune pour faciliter la lecture et compréhension du fichier.

Si quelqu'un aurait une idée pour m'aider, ce serait génial.

Merci d'avance

 

[david84]

Re : Extraire les différences entre 2 feuilles

Bonjour,
je n'ai pas ouvert tes fichiers mais peut-être trouveras-tu des pistes ici sur le site de Jacques Boisgontier.
A+

 

[Ghost]

Re : Extraire les différences entre 2 feuilles

Merci, ce site est vraiment une mine d'or.

J'y ai trouvé exactement ce dont j'avais besoin pour démarrer, je n'ai eut qu'à effectuer quelques adaptations et c'est parfait.

Merci encore

 

[Ghost]

Re : Extraire les différences entre 2 feuilles

Bonjour,
je n'ai pas ouvert tes fichiers mais peut-être trouveras-tu des pistes ici sur le site de Jacques Boisgontier.
A+

Merci, ce site est vraiment une mine d'or.

J'y ai trouvé exactement ce dont j'avais besoin pour démarrer, je n'ai eut qu'à effectuer quelques adaptations et c'est parfait.

Merci encore

 Application.ScreenUpdating = False
 Sheets("Différence").Range("A3:G1000").ClearContents
 Sheets("Différence").Range("J3:P1000").ClearContents
  Set f1 = Sheets("ARP NEW")
  Set f2 = Sheets("ARP")
  Set g1 = Sheets("ARP")
  Set g2 = Sheets("ARP NEW")
  
  A = f2.Range("A1").CurrentRegion.Value
  B = f1.Range("A1").CurrentRegion.Value
  M = g2.Range("A1").CurrentRegion.Value
  N = g1.Range("A1").CurrentRegion.Value
  
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(A)
    temp = ""
    For k = 1 To UBound(A, 2): temp = temp & A(i, k): Next k
    MonDico1(temp) = 1
  Next i
  ligne = 1
  Dim c
  ReDim c(1 To Application.Max(UBound(A), UBound(B)), 1 To UBound(A, 2))
  For i = 1 To UBound(B)
    temp = ""
    For k = 1 To UBound(B, 2): temp = temp & B(i, k): Next k
    If Not MonDico1.exists(temp) Then
      For k = 1 To UBound(B, 2): c(ligne, k) = B(i, k): Next k
      ligne = ligne + 1
    End If
  Next
  Sheets("Différence").[H3].Resize(UBound(A, 1), UBound(A, 2)) = c




  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For j = 1 To UBound(M)
    temp = ""
    For l = 1 To UBound(M, 2): temp = temp & M(j, l): Next l
    MonDico2(temp) = 1
  Next j
  ligne = 1
  Dim d
  ReDim d(1 To Application.Max(UBound(M), UBound(N)), 1 To UBound(M, 2))
  For j = 1 To UBound(N)
    temp = ""
    For l = 1 To UBound(N, 2): temp = temp & N(j, l): Next l
    If Not MonDico2.exists(temp) Then
      For l = 1 To UBound(N, 2): d(ligne, l) = N(j, l): Next l
      ligne = ligne + 1
    End If
  Next
  Sheets("Différence").[A3].Resize(UBound(M, 1), UBound(M, 2)) = d