comparaison de 2 feuilles avec création auto d'un 3e faisant ressortir les écarts

B

booccsn

XLDnaute Nouveau
bonjour à tous

je suis en train de travailler sur un fichier comprenant 3 feuilles :
- inventaire 2008 (4 colonees) avec ref, nom, qté, pu
- inventaire 2009 (4 colonees) avec ref, nom, qté, pu
je voudrais donc générer une 3e feuille avec 4 colonnes:
ref, nom, pu, écart des 2 qtés.

NB : j'ai des ref de 2008 qui ne sont en 2009 et vice versa. j'ai déjà récupéré une macro qui a réussi à le faire mais n'a pas réussi à me mettre les ref qui ne sont pas communes aux deux années ;
je pense qu'il faut prévoir quelque part que si la ref n'existe pas, l'interpréter comme valeur 0.

Merci pour votre aide.
je dois faire la procédure sur un doc de 2500 références. faudra t-il faire un recopie vers le bas ou une macro ? je ne sais pas
je joins le modèle
 

Pièces jointes

  • inventaire.xls
    18 KB · Affichages: 82
  • inventaire.xls
    18 KB · Affichages: 79
  • inventaire.xls
    18 KB · Affichages: 83
Trier par date Trier par votes
C

Catrice

XLDnaute Barbatruc
Re : comparaison de 2 feuilles avec création auto d'un 3e faisant ressortir les écart

Bonjour,

Peux tu montrer un exemple de ce que tu veux dans la feuille Ecart ?
Que faut il faire quand la REf n'est que dans une feuille ?
Les prix sont -ils tjs identiques dans chaque feuille ?
 
Vote positif 0 Vote négatif
B

booccsn

XLDnaute Nouveau
Re : comparaison de 2 feuilles avec création auto d'un 3e faisant ressortir les écart

Catrice à dit:
Bonjour,

Peux tu montrer un exemple de ce que tu veux dans la feuille Ecart ?
Que faut il faire quand la REf n'est que dans une feuille ?
Les prix sont -ils tjs identiques dans chaque feuille ?
Cliquez pour agrandir...

Oui j'ai déjà joint le fichier avec les 3 feuilles et ce que je voudrais ; quand la ref n'est que dans une feuille, la traiter pareil en considérant que la qté était 0.
merrci
 
Vote positif 0 Vote négatif
B

booccsn

XLDnaute Nouveau
Vote positif 0 Vote négatif
C

Catrice

XLDnaute Barbatruc
Re : comparaison de 2 feuilles avec création auto d'un 3e faisant ressortir les écart

Re,

Je propose la solution jointe.
Mais je manque de précision sur ce que tu souhaites à l'arrivée ...

Edit : j'ai trouvé tellement bien la 6eme colonne de Boisgontier que je l'ai implementé dans ma version.
 

Pièces jointes

  • inventaire.xls
    37 KB · Affichages: 156
  • inventaire.xls
    37 KB · Affichages: 164
  • inventaire.xls
    37 KB · Affichages: 159
Dernière édition:
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : comparaison de 2 feuilles avec création auto d'un 3e faisant ressortir les écart

Bonsoir à tous.
J'ai testé les solutions de BOISGONTIER et de Catrice sur un échantillon de 22 378 références. Plus précisément :
Références..........................Nombre
__________________________________________

pour les deux années................22 378
2008................................20 708
2009................................20 745
communes aux deux années............19 075
abandonnées en 2009..................1 633
introduites en 2009..................1 670​
Les deux solutions fonctionnent parfaitement, mais je les ai trouvées lentes : plus de six minutes et demi pour l'une et neuf minutes et des poussières pour l'autre. J'ai cherché à augmenter la vitesse en reprenant le problème à la base. Ce qui donne :
Code: 
Sub Delta()
Dim i As Long, j As Long, k As Long, v8, v9
Dim a8(), a9(), d89(), UL8 As Long, UL9 As Long, UL89 As Long, UC8 As Long, UC9 As Long
Dim r2Calc As Long
    r2Calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    a8 = Sheets("2008").Cells(1, 1).CurrentRegion.Value
    a9 = Sheets("2009").Cells(1, 1).CurrentRegion.Value
    d89 = Sheets("ECART").Range(Cells(1, 1), Cells(1, 5)).Value
    d89 = Application.Transpose(d89)
    UL8 = UBound(a8, 1)
    UL9 = UBound(a9, 1)
    UC8 = UBound(a8, 2)
    UC9 = UBound(a9, 2)
    UL89 = 1
    Sheets.Add Before:=Sheets("ECART")
    With ActiveSheet
        .Columns("A:A").NumberFormat = "@"
        With .Range(.Cells(1, 1), .Cells(UL8 + 1, UC8))
            .Value = a8
            .Cells(UL8 + 1, 1).Value = Chr(255)
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlYes, MatchCase:=True
            a8 = .Value
        End With
        .Cells.ClearContents
        With .Range(.Cells(1, 1), .Cells(UL9 + 1, UC9))
            .Value = a9
            .Cells(UL9 + 1, 1).Value = Chr(255)
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlYes, MatchCase:=True
            a9 = .Value
        End With
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        .Delete
        Application.EnableEvents = True
        Application.DisplayAlerts = True
    End With
    i = 2
    j = 2
    Do Until i + j > UL8 + UL9 + 1
        UL89 = UL89 + 1
        ReDim Preserve d89(1 To 5, 1 To UL89)
        v8 = a8(i, 1)
        v9 = a9(j, 1)
        If v9 = v8 Then
            For k = 1 To 4: d89(k, UL89) = a9(j, k): Next k
            d89(3, UL89) = d89(3, UL89) - a8(i, 3)
            i = i + 1: j = j + 1
        Else
            If v9 > v8 Then
                For k = 1 To 4: d89(k, UL89) = a8(i, k): Next k
                d89(3, UL89) = -a8(i, 3)
                d89(5, UL89) = 2008
                i = i + 1
            Else
                For k = 1 To 4: d89(k, UL89) = a9(j, k): Next k
                d89(5, UL89) = 2009
                j = j + 1
            End If
        End If
    Loop
    Sheets("ECART").Cells(1, 1).CurrentRegion.ClearContents
    Sheets("ECART").Range(Cells(1, 1), Cells(UL89, 5)).Value = Application.Transpose(d89)
    Application.ScreenUpdating = True
    Application.Calculation = r2Calc
End Sub
qui s'exécute en trois secondes et deux dixièmes. Ce me semble trop beau pour être vrai. Aussi vous serais-je reconnaissant si l'un ou l'autre d'entre-vous pouvait valider la chose ou, le cas échéant, trouver la faille. Merci d'avance !​
Bonne nuit !
ROGER2327

__________________
(La pièce jointe ne comporte évidemment pas les données de test.)
 

Pièces jointes

  • inventaire_v3.xls
    34 KB · Affichages: 84
Vote positif 0 Vote négatif
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : comparaison de 2 feuilles avec création auto d'un 3e faisant ressortir les écart

Bonsoir,

Autre méthode + rapide

Code: 
Sub CompareBD1()
    Application.ScreenUpdating = False
    Set f1 = Sheets("2008")
    Set f2 = Sheets("2009")
    Set f3 = Sheets("ecart")
    ligne = 1
    n1 = f1.Range("A65000").End(xlUp).Row
    n2 = f2.Range("A65000").End(xlUp).Row
    a = f1.Range("A2:D" & n1).Value
    b = f2.Range("A2:D" & n2).Value
    Set mondico1 = CreateObject("Scripting.Dictionary")
    For i = 1 To n1 - 1: mondico1.Add a(i, 1), i: Next
    Set mondico2 = CreateObject("Scripting.Dictionary")
    For i = 1 To n2 - 1: mondico2.Add b(i, 1), i: Next
    Dim c()
    n = n1 + n2
    ReDim c(1 To n, 1 To 6)
    [A2:L30000].ClearContents
    '--- communs
    For i = 1 To n1 - 1
      temp = a(i, 1)
      If mondico2.Exists(temp) Then
        p = mondico2.Item(temp)
        For k = 1 To 4: c(ligne, k) = a(i, k): Next k
        c(ligne, 5) = b(p, 3) - a(i, 3)
        c(ligne, 6) = "Communs"
        ligne = ligne + 1
      End If
    Next i
    '--- BD2-BD1
    For i = 1 To n2 - 1
      temp = b(i, 1)
      If Not mondico1.Exists(temp) Then
        p = mondico2.Item(temp)
        For k = 1 To 4: c(ligne, k) = b(i, k): Next k
        c(ligne, 5) = b(p, 3)
        c(ligne, 6) = f2.Name
        ligne = ligne + 1
      End If
    Next i
    '---  BD1-BD2
    For i = 1 To n1 - 1
      temp = a(i, 1)
      If Not mondico2.Exists(temp) Then
        p = mondico1.Item(temp)
        For k = 1 To 4
          c(ligne, k) = a(i, k)
        Next k
        c(ligne, 5) = -a(p, 3)
        c(ligne, 6) = f1.Name
        ligne = ligne + 1
      End If
    Next i
    f3.[A2].Resize(ligne, 6) = c
 End Sub

JB
 

Pièces jointes

  • CompareBD4.zip
    14.5 KB · Affichages: 71
Dernière édition:
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : comparaison de 2 feuilles avec création auto d'un 3e faisant ressortir les écart

Bonsoir à tous.
Merci à BOISGONTIER pour l'idée de recourir à l'objet Dictionnary de VBS. Le résultat est étonnant puisqu'avec mes données de test, le temps d'exécution est d'un peu plus d'une seconde et demie. Cela montre bien que, dès qu'on veut de la vitesse, il faut travailler uniquement sur des variables VB et recourir le moins possible à l'interface.
Le seul point qui m'embête dans votre proposition est le dimensionnement très généreux du tableau c (ReDim c(1 To n, 1 To 6)) avec n = n1 + n2. J'ai cherché à éviter ce "gaspillage" en créant un index (dictionnary) supplémentaire. Cela coûte une bonne demi-seconde de plus. Autrement dit, vitesse et économie se combattent...
J'obtiens ceci :
Code: 
Option Explicit
Option Compare Binary

Sub communs() [COLOR="SeaGreen"]'sur une idée de BOIGONTIER,
' http://www.excel-downloads.com/forum/114504-comparaison-de-2-feuilles-avec-cr-ation-auto-dun-3e-faisant-ressortir-les-carts.html[/COLOR]
Dim t As Single [COLOR="SeaGreen"]'***[/COLOR]
    t = Timer [COLOR="SeaGreen"]'***[/COLOR]
Dim i As Long, j As Long, n1 As Long, n2 As Long, f1 As String, f2 As String, f3 As String
Dim a1, a2, d1, d2, c(), x, p
[COLOR="DarkOrange"]Dim d3, id3[/COLOR]
    Application.ScreenUpdating = False
    f1 = "2008"
    f2 = "2009"
    f3 = "Ecart"
    With Sheets(f1)
        n1 = .[a1].End(xlDown).Row
        a1 = .Range("A2:D" & n1).Value
    End With
    With Sheets(f2)
        n2 = .[a1].End(xlDown).Row
        a2 = .Range("A2:D" & n2).Value
    End With
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    [COLOR="DarkOrange"]Set d3 = CreateObject("Scripting.Dictionary")[/COLOR]
    For i = 1 To n1 - 1: d1.Add a1(i, 1), i: [COLOR="DarkOrange"]d3.Add a1(i, 1), i[/COLOR]: Next i
    For j = 1 To n2 - 1: d2.Add a2(j, 1), j
        [COLOR="DarkOrange"]If Not d3.Exists(a2(j, 1)) Then d3.Add a2(j, 1), j: i = i + 1[/COLOR]
    Next j
    [COLOR="DarkOrange"]id3 = d3.keys[/COLOR]
    Set d3 = Nothing
    [COLOR="DarkOrange"]ReDim c(1 To i - 1, 1 To 5)[/COLOR]
    For i = 1 To i - 1
        x = id3(i - 1)
        Select Case d1.Exists(x) - d2.Exists(x)
            Case 0 [COLOR="SeaGreen"]'--- communs[/COLOR]
                p = d2.Item(x)
                For j = 1 To 4: c(i, j) = a2(p, j): Next j
                c(i, 3) = c(i, 3) - a1(d1.Item(x), 3)
                c(i, 5) = "C"
            Case -1 [COLOR="SeaGreen"]'--- BD1 seul[/COLOR]
                p = d1.Item(x)
                For j = 1 To 4: c(i, j) = a1(p, j): Next j
                c(i, 3) = -c(i, 3)
                c(i, 5) = f1
            Case 1 [COLOR="SeaGreen"]'--- BD2 seul[/COLOR]
                p = d2.Item(x)
                For j = 1 To 4: c(i, j) = a2(p, j): Next j
                c(i, 5) = f2
        End Select
    Next i
    Set d1 = Nothing
    Set d2 = Nothing
    With Sheets(f3)
        .Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
        .[a2].Resize(i - 1, 5) = c
        .[a1].CurrentRegion.Sort key1:=.[a1], order1:=xlAscending, header:=xlYes, MatchCase:=True [COLOR="SeaGreen"]'***[/COLOR]
    End With
    MsgBox "Durée d'exécution : " & Round(Timer - t, 2) & " s." [COLOR="SeaGreen"]'***[/COLOR]
 End Sub
(J'ai gardé la structure initiale de la feuille "Ecart" pour poursuivre la comparaison des vitesses des différentes méthodes.)
Tout cela juste par curiosité : de temps à autre, j'aime bien dépasser la seule obtention d'un résultat utilisable, et voir un peu les choses en profondeur. Merci à vous de m'avoir procuré cette occasion.​
Cordialement,
ROGER2327
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Question
Microsoft 365 Création d'un TCD avec 2 tableaux ayant les mêmes entêtes de colonne et les même données
Réponses
9
Affichages
347
STEPHANIE1975
S
M
  • Résolu(e)
XL 2013 Copier un Userform d'un fichier Excel vers un autre avec en l'adaptant avec les nouvelles feuilles
Réponses
10
Affichages
2 K
metalbarzotti
M
apicius46
  • Question
[Réglé] Sur 2 feuilles comparaison de colonne de nom croisn avec séparation de ligne
Réponses
2
Affichages
571
apicius46
apicius46
T
  • Question
Comparer 2 feuilles et copier une cellule de feuille 2 à feuille1, si égalité de réf.
Réponses
1
Affichages
3 K
Toine45
T
P
  • Question
Rassembler les données de 2 feuilles en une seule avec liein référentiel
Réponses
4
Affichages
842
JHA
J
B
  • Question
Lier des plages de cellules de 2 feuilles différentes dans les 2 sens
Réponses
2
Affichages
3 K
BUX07
B
M
  • Question
Simplifier code via une boucle avec comme variable les numéros de feuilles paires
Réponses
8
Affichages
1 K
micapilote
M
I
  • Question
Faire ressortir les éléments communs d'un tableau
Réponses
7
Affichages
3 K
ROGER2327
ROGER2327
koewin
  • Question
Comparaison automatique de 2 feuilles
2
Réponses
22
Affichages
3 K
tototiti2008
tototiti2008

Membres actuellement en ligne

4 membres et 54 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 765
Messages
2 091 888
Membres
105 084
dernier inscrit
lca.pertus