XL 2013 comparaison de listes

[ivan27]

Bonjour à tous,
Je souhaiterais comparer des données de deux classeurs et récupérer des données dans un troisième classeur pour faire un calcul :
Si dans les classeurs STT1 et STT2 les numéros de la colonne A sont identiques et les montants de la colonne B sont différents, je récupère dans un troisième classeur la ligne correspondante de STT1.
Je récupère dans le troisième classeur en colonne G le montant STT2 et je calcule l'écart en colonne H.
Je souhaiterais faire cette manipulation alors que les classeurs STT1 et STT2 sont fermés.
Chaque classeur fait entre 70 et 100000 lignes.
Merci pour votre aide.
Ivan

 

[klin89]

Bonjour à tous,

Un truc me chagrine :
D'une base à l'autre, on retrouve les mêmes références en colonne 1, le nombre de lignes est également identique, est-ce bien normal

Option Explicit
Sub test()
Dim a, i As Long, j As Long, w(), x, y, e
    a = Sheets("Feuil1").Range("a1").CurrentRegion.Value 'STT1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            ReDim w(1 To 8)
            For j = 1 To UBound(a, 2)
                w(j) = a(i, j)
            Next
            .Item(a(i, 1)) = w
        Next
        a = Sheets("Feuil2").Range("a1").CurrentRegion.Value 'STT2
        For i = 2 To UBound(a, 1)
            If .exists(a(i, 1)) Then
                w = .Item(a(i, 1))
                w(7) = a(i, 2)
                w(8) = w(7) - w(2)
            End If
            .Item(a(i, 1)) = w
        Next
        For Each e In .keys
            If .Item(e)(8) = 0 Then .Remove e
        Next
        y = .items: x = .Count
    End With
    If x > 0 Then
        Application.ScreenUpdating = False
        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets("Resultat").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Sheets.Add.Name = "Resultat"
        With Sheets("Resultat").Cells(1)
            .Resize(1, 8).Value = Array("Référence", "Montant", "Code 1", _
                          "Code 2", "Nom", "Date", "Montant STT2", "Ecart")
            .Offset(1).Resize(x, 8).Value = _
            Application.Transpose(Application.Transpose(y))
            With .CurrentRegion
                .Font.Name = "calibri"
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                With .Rows(1)
                    .HorizontalAlignment = xlCenter
                    .Interior.ColorIndex = 40
                    .Font.Bold = True
                    .BorderAround Weight:=xlThin
                End With
                '.Columns.AutoFit
            End With
        End With
        Application.ScreenUpdating = True
    Else
        MsgBox "Aucune donnée"
    End If
End Sub

klin89

 

[ivan27]

Bonjour le forum, klin89, gosselien,

Merci beaucoup pour cette proposition qui fonctionne parfaitement avec le fichier exemple joint.
Les références et nombre de lignes sont effectivement identiques car je fais une extraction dans une base de données (stt1) sur une période donnée. Après avoir réalisé des modifications dans ma BDD susceptibles d'impacter la seconde colonne, je fais une nouvelle extraction (stt2) et je compare les 2 fichiers.
Les 2 extractions pourraient présenter quelques différences en cas de modification sur les dates et il faut dans ce cas écarter du résultat les lignes dont la référence unique de la colonne A ne figure pas dans les 2 fichiers.
Je vous réitère mes remerciements.
Bon week-end à tous
Ivan

 

[klin89]

Re Ivan27

Dans ce cas, on va faire un peu plus simple.
J'évite aussi Application.Transpose

Option Explicit
Sub test()
Dim a, i As Long, j As Long, n As Long, w(), e
a = Sheets("Feuil1").Range("a1").CurrentRegion.Value    'STT1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            ReDim w(1 To 8)
            For j = 1 To UBound(a, 2)
                w(j) = a(i, j)
            Next
            .Item(a(i, 1)) = w
        Next
        a = Sheets("Feuil2").Range("a1").CurrentRegion.Value    'STT2
        For i = 2 To UBound(a, 1)
            w = .Item(a(i, 1))
            w(7) = a(i, 2)
            w(8) = w(7) - w(2)
            .Item(a(i, 1)) = w
        Next
        ReDim a(1 To .Count, 1 To 8)
        For Each e In .keys
            If .Item(e)(8) <> 0 Then
                n = n + 1
                For j = 1 To UBound(.Item(e))
                    a(n, j) = .Item(e)(j)
                Next
            End If
        Next
    End With
    If n > 0 Then
        Application.ScreenUpdating = False
        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets("Resultat").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Sheets.Add.Name = "Resultat"
        With Sheets("Resultat").Cells(1)
            .Resize(1, UBound(a, 2)).Value = Array("Référence", "Montant", _
                 "Code 1", "Code 2", "Nom", "Date", "Montant STT2", "Ecart")
            .Offset(1).Resize(n, UBound(a, 2)).Value = a
            With .CurrentRegion
                .Font.Name = "calibri"
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                With .Rows(1)
                    .HorizontalAlignment = xlCenter
                    .Interior.ColorIndex = 40
                    .Font.Bold = True
                    .BorderAround Weight:=xlThin
                End With
                '.Columns.AutoFit
            End With
        End With
        Application.ScreenUpdating = True
    Else
        MsgBox "Aucune donnée"
    End If
End Sub