Fusion des valeurs équivalentes entre deux feuilles de calce

Le 29/05/2017 à 04:42

Bonjour,

Le titre n'est certainement pas trés explicite, je vais donc essayer d'être plus clair.

Dans le cadre d'un stage en entreprise, je suis chargé d'expliquer l'écart entre deux inventaires réalisés par deux équipes différentes.

J'ai compilé les résultats de ces deux inventaires sur deux feuilles.

Je souhaite retrouver sur une troisième feuille pour chaque Code article les références correspondantes aux deux inventaires sur une même ligne.

J'ai essayé divers moyens sans succès. J'ai doc entré manuellement les valeurs de la feuille 3 à titre d'exemple.

Merci d'avance pour votre indulgence (c'est mon premier post sur ce forum), et pour votre assistance.

Ci-joint le fichier en question.

30inventaires.xlsx (907.71 Ko)
Le 29/05/2017 à 10:33

Bonjour,

Sub RécapInventaire()
    Dim Rcp(), d1 As Object, d2 As Object, k, itm, n&, i&, j&, r&
    Dim dmax As Object, dmin As Object, m
    Set d1 = CreateObject("Scripting.Dictionary")
    With Worksheets("Inv Equipe1")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            k = Trim(.Cells(i, 1))
            For j = 2 To 5
                itm = itm & ";" & .Cells(i, j)
            Next j
            d1(k) = itm
            itm = ""
        Next i
    End With
    Set d2 = CreateObject("Scripting.Dictionary")
    With Worksheets("Inv Equipe2")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            k = Trim(.Cells(i, 1))
            For j = 2 To 5
                itm = itm & ";" & .Cells(i, j)
            Next j
            d2(k) = itm
            itm = ""
        Next i
    End With
    If d1.Count < d2.Count Then
        Set dmax = d2
        Set dmin = d1
        m = Array(3, 0)
    Else
        Set dmax = d1
        Set dmin = d2
        m = Array(0, 3)
    End If
    ReDim Rcp(dmax.Count, 8)
    For Each k In dmax
        itm = Split(dmax(k), ";")
        Rcp(r, 0) = k: Rcp(r, 1) = itm(1)
        For i = 2 To 4
            Rcp(r, i + m(0)) = Val(Replace(itm(i), ",", "."))
        Next i
        If dmin.exists(k) Then
            itm = Split(dmin(k), ";")
            For i = 2 To 4
                Rcp(r, i + m(1)) = Val(Replace(itm(i), ",", "."))
            Next i
        End If
        Rcp(r, 8) = IIf(Rcp(r, 7) - Rcp(r, 4) <> 0, Rcp(r, 7) - Rcp(r, 4), "")
        r = r + 1
    Next k
    With Worksheets("Récap")
        Application.ScreenUpdating = False
        .Range("A1").CurrentRegion.Offset(1).Clear
        With .Range("A2").Resize(r, 9)
            .Value = Rcp
            For j = 4 To 9
                If j <> 6 Then .Columns(j).NumberFormat = "0.00"
            Next j
        End With
    End With
End Sub

Bouton sur feuille récap.

Je suis un peu pressé dans l'instant, mais on peut compléter la mise en forme du tableau résultant...

Cordialement.

Le 29/05/2017 à 14:38

Bonjour MFerrand,

Je suis bluffé par la rapidité de ta réponse!

Merci infiniment pour ton aide!

je teste tout de suite...

Le 29/05/2017 à 15:15

Bonjour MFerrand,

C'est juste parfait!!!

Merci pour cette précieuse aide qui m'épargne des heures de travail fastidieuses!

Le 30/05/2017 à 21:04

Bonsoir Doubal,

MaPoire vient de me faire remarquer une carence dans mon code : le fait qu'un code I51151-53 est différencé du code i51151-53 recensé par l'autre équipe. Et qu'il faudrait donc faire en sorte que l'outil dico ne différencie pas les clé selon la casse.

Je vais donc réviser, mais en appliquant aux clés la mise en majuscules (j'opérais d'jà une suppression d'espaces parasites éventuels...) de façon que la récap ne comporte que des codes en majuscules.

Mais sa signalisation m'a surtout fait constater que j'avais implicitement pris en compte que l'équipe qui recensait le moins de codes aurait nécessairement tous ses codes inclus dans le recensement de l'équipe qui en recensait le plus ! C'est peut-être vrai, mais rien n'interdit que cela ne soit pas, et il convient donc d'en tenir compte.

Je vais donc réviser le code dans ce sens...

Merci à MaPoire !

A suivre...

Le 30/05/2017 à 21:40

Voilà le fichier avec code complété.

Par rapport au code précédent :

  • On met la clé (c'est le code article) en majuscules, ce qui élimine des différences dues à la casse.
  • On fait un tableau (Colonnes, Lignes) au lieu d'un tableau (Lignes, Colonnes) pour recueillir les résultats, pour conserver la possibilité de l'étendre après la première phase (seule la dernière dimension peut être modifiée dans un tableau dynamique en conservant les valeurs déjà affectées, et ce sont les lignes qui varient...)
  • La 1re phase se déroule pareil, sauf inversion des indices liée au dimensionnement, et suppression des éléments de dmin (dico d'éléments de l'inventaire de l'équipe qui en a recensé le moins) après affectation au tableau.
  • Ajout : test s'il reste des éléments de dmin (non affectés donc), et si c'est le cas redimensionnement du tableau pour ajouter ces éléments et ajout des éléments...
  • Affectation du tableau en le transposant (puisqu'on a inversé lignes et colonnes).

Cordialement et merci à MaPoire

Je mets le code, le fichier est trop lourd pour passer.

Sub RécapInventaire()
    Dim Rcp(), d1 As Object, d2 As Object, k, itm, n&, i&, j&, r&
    Dim dmax As Object, dmin As Object, m
    Set d1 = CreateObject("Scripting.Dictionary")
    With Worksheets("Inv Equipe1")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            k = UCase(Trim(.Cells(i, 1)))
            For j = 2 To 5
                itm = itm & ";" & .Cells(i, j)
            Next j
            d1(k) = itm
            itm = ""
        Next i
    End With
    Set d2 = CreateObject("Scripting.Dictionary")
    With Worksheets("Inv Equipe2")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            k = UCase(Trim(.Cells(i, 1)))
            For j = 2 To 5
                itm = itm & ";" & .Cells(i, j)
            Next j
            d2(k) = itm
            itm = ""
        Next i
    End With
    If d1.Count < d2.Count Then
        Set dmax = d2
        Set dmin = d1
        m = Array(3, 0)
    Else
        Set dmax = d1
        Set dmin = d2
        m = Array(0, 3)
    End If
    ReDim Rcp(8, dmax.Count)
    For Each k In dmax
        itm = Split(dmax(k), ";")
        Rcp(0, r) = k: Rcp(1, r) = itm(1)
        For i = 2 To 4
            Rcp(i + m(0), r) = Val(Replace(itm(i), ",", "."))
        Next i
        If dmin.exists(k) Then
            itm = Split(dmin(k), ";")
            For i = 2 To 4
                Rcp(i + m(1), r) = Val(Replace(itm(i), ",", "."))
            Next i
            dmin.Remove (k)
        End If
        Rcp(8, r) = IIf(Rcp(7, r) - Rcp(4, r) <> 0, Rcp(7, r) - Rcp(4, r), "")
        r = r + 1
    Next k
    If dmin.Count > 0 Then
        ReDim Preserve Rcp(8, UBound(Rcp) + dmin.Count)
        For Each k In dmin
            itm = Split(dmin(k), ";")
            Rcp(0, r) = k: Rcp(1, r) = itm(1)
            For i = 2 To 4
                Rcp(i + m(1), r) = Val(Replace(itm(i), ",", "."))
            Next i
            Rcp(8, r) = IIf(Rcp(7, r) - Rcp(4, r) <> 0, Rcp(7, r) - Rcp(4, r), "")
            r = r + 1
        Next k
    End If
    With Worksheets("Récap")
        Application.ScreenUpdating = False
        .Range("A1").CurrentRegion.Offset(1).Clear
        With .Range("A2").Resize(r, 9)
            .Value = WorksheetFunction.Transpose(Rcp)
            For j = 4 To 9
                If j <> 6 Then .Columns(j).NumberFormat = "0.00"
            Next j
        End With
    End With
End Sub
Le 30/05/2017 à 22:31

Bonjour MFerrand

Ai-je bien compris

Par défaut le mode de comparaison des clés d'un dictionnaire est fixé comme ceci :

d1.CompareMode = 0

c'est à dire que toto est différent de TOTO

Ci-dessous : toto est l'équivalent de TOTO

Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = 1

klin89

Le 30/05/2017 à 22:36

Exact Klin89 ! Mais je n'ai pas utilisé la définition du mode de comparaison et préféré basculé tout en majuscule (ce qui assurera aussi la comparaison) pour être sur de n'avoir dans la Récap que des majuscules.

Cordialement.

Le 31/05/2017 à 00:01

Bonsoir à tous,

J'avais commencé à écrire du code mais Mferrand a répondu si vite que j'ai arrêté le codage.

J'ai repris et terminé le travail en espérant qu'il sera juste. Je n'ai pas fait toutes les vérifications qui pourraient s'imposer.

J'ai considéré qu'aucun des deux inventaires n'était vide, qu'il n'y avait pas de doublons, qu'il n'y avait pas de ligne de totaux, qu'il n'y avait pas de filtre et fait fi que pour certains articles les désignations étaient diffrérentes dans les deux inventaires, ...etc.

La méthode utilisée diffère grandement de celle de Mferrand.

11doubal-inventaires-v1.xlsm (976.19 Ko)
Rechercher des sujets similaires à "fusion valeurs equivalentes entre deux feuilles calce"