Regroupement de doublons dans un tableau

Bonjour,

J'ai un fichier regroupant des organes (rouleau, moteur, tambour etc...) ainsi que leur caractéristiques et leur quantité en fonction de l'équipement auxquels ils appartiennent. Il arrive que certains organes soit communs à plusieurs équipement et je souhaiterai pouvoir regrouper tous les organes ayant les même caractéristiques pour connaître le nombre total. Il faudrait donc que la colonne quantité soit additionné avant le regroupement en une seule ligne.

Seuls les colonnes de caractéristiques seraient à prendre en compte pour savoir si les organes sont identiques et donc à grouper.

Le fichier réel comporte plus de caractéristiques que celles présentes pour l'exemple.

Je tire déjà cette liste à travers un code vba qui copie tout dans ce format de tableau-ci, et j'aimerai ajouter à ce code le regroupement des doublons.

J'espère que vous pourrez m'aider.

Bonne journée

Il y a deux tableaux ou un seul?

Bonjour,

Une proposition Power Query, (Recherchercher et transformer des données), intégré à ta version Excel.

Cdlt.

Bonjour,

Merci de votre rapidité

Non il n'y a qu'un seul tableau, celui de gauche.

Celui de droite est un modèle de ce que je souhaiterai avoir, les couleurs ne servent seulement à montrer les regroupements pour une meilleure compréhension.

Je ne connaissais pas le système power query, il semble répondre à mes attentes, mais je souhaiterai avoir un code vba, car le fichier étant destiné à être utiliser par de nombreuses personnes n'ayant pas forcément de grandes connaissances sur excel. Je souhaiterai donc combiner cette fonction avec celle qui me permet d'extraire ma liste d'organe. Et n'avoir qu'un seul bouton pour les deux fonctions.

J'ai trouvé une solution qui utilise la fonction des dictionnaires.

Pour ceux que ça intéresse je mets le code final :

Dim mondico(6)
Dim i As Integer
Dim j As Integer
Application.ScreenUpdating = True

Set f1 = Sheets("Feuil10")
a = f1.Range("A1").CurrentRegion.Value
f1.Range("P1").CurrentRegion.Clear

For i = 1 To 6
    Set mondico(i) = CreateObject("Scripting.Dictionary")
Next

For i = 1 To 6
    mondico(i).RemoveAll
Next

For i = 2 To UBound(a)
    temp = a(i, 4) & " / " & a(i, 5) & " / " & a(i, 6) & " / " & a(i, 7) & " / " & a(i, 3)
    mondico(1)(temp) = mondico(1)(temp) + a(i, UBound(a, 2))
    For j = 2 To 6
        mondico(j)(temp) = a(i, j + 1)
    Next
Next

For x = 2 To 6
f1.Cells(1, x + 14).Resize(mondico(1).Count) = Application.Transpose(mondico(x).items)
Next
f1.[U1].Resize(mondico(1).Count) = Application.Transpose(mondico(1).items)

Bonjour à tous,

Bonjour Mending

Comme les dictionnaires ont l'air de vous intéresser, essayez ceci :

Option Explicit
Sub test()
    Dim a, w(), i As Long, txt As String, e, n As Long, dico As Object
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Exemple").Cells(1).CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 3)) Then
            Set dico(a(i, 3)) = CreateObject("Scripting.Dictionary")
            dico(a(i, 3)).CompareMode = 1
        End If
        txt = Join$(Array(a(i, 4), a(i, 5), a(i, 6), a(i, 7)), "|")
        If Not dico(a(i, 3)).exists(txt) Then
            dico(a(i, 3))(txt) = VBA.Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5), a(i, 6), a(i, 7), a(i, 8))
        Else
            w = dico(a(i, 3))(txt)
            If InStr(w(0), a(i, 1)) = 0 Then w(0) = w(0) & "|" & a(i, 1)
            If InStr(w(1), a(i, 2)) = 0 Then w(1) = w(1) & "|" & a(i, 2)
            w(7) = w(7) + a(i, 8)
            dico(a(i, 3))(txt) = w
        End If
    Next
    With Sheets.Add
        With .Cells(1).Resize(, 8)
            .Value = Array(a(1, 1), a(1, 2), a(1, 3), a(1, 4), "", "", "", a(1, 8))
            .HorizontalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Interior.Color = 4697456
            With .Cells(4).Resize(, 4)
                .HorizontalAlignment = xlCenterAcrossSelection
                .Interior.Color = 9359529
            End With
        End With
        n = 2
        For Each e In dico.keys
            With .Cells(n, 1).Resize(dico(e).Count, UBound(Application.Index(dico(e).Items, 0, 0), 2))
                .Value = Application.Index(dico(e).Items, 0, 0)
                .BorderAround Weight:=xlThin
            End With
            n = n + dico.Item(e).Count
        Next
        With .Cells(1).CurrentRegion
            .Borders(xlInsideVertical).Weight = xlThin
            .VerticalAlignment = xlCenter
            .Columns.AutoFit
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Re Mending,

Essayez plutôt ceci :

Option Explicit
Sub test()
    Dim a, w(), i As Long, txt As String, e, s, n As Long, dico As Object
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Exemple").Cells(1).CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 3)) Then
            Set dico(a(i, 3)) = CreateObject("Scripting.Dictionary")
            dico(a(i, 3)).CompareMode = 1
        End If
        txt = Join$(Array(a(i, 4), a(i, 5), a(i, 6), a(i, 7)), "|")
        If Not dico(a(i, 3)).exists(txt) Then
            ReDim w(1 To 3)
            Set w(1) = CreateObject("Scripting.Dictionary")
            w(1).CompareMode = 1
            Set w(2) = CreateObject("Scripting.Dictionary")
            w(2).CompareMode = 1
            w(3) = VBA.Array(Empty, Empty, a(i, 3), a(i, 4), a(i, 5), a(i, 6), a(i, 7), 0)
            dico(a(i, 3))(txt) = w
        End If
        w = dico(a(i, 3))(txt)
        If Not w(1).exists(a(i, 1)) Then
            w(1)(a(i, 1)) = Empty
            w(3)(0) = w(3)(0) & IIf(w(3)(0) <> "", "|", "") & a(i, 1)
        End If
        If Not w(2).exists(a(i, 2)) Then
            w(2)(a(i, 2)) = Empty
            w(3)(1) = w(3)(1) & IIf(w(3)(1) <> "", "|", "") & a(i, 2)
        End If
        w(3)(7) = w(3)(7) + a(i, 8)
        dico(a(i, 3))(txt) = w
    Next
    With Sheets.Add
        With .Cells(1).Resize(, 8)
            .Value = Application.Index(a, 1, 0)
        End With
        n = 2
        For Each e In dico.keys
            For Each s In dico(e).keys
                With .Cells(n, 1).Resize(1, UBound(dico(e)(s)(3), 1) + 1)
                    .Value = dico(e)(s)(3)
                End With
                n = n + 1
            Next
            With .Cells(n, 1).Resize(1, UBound(a, 2))
                .Borders(xlEdgeTop).Weight = xlThin
            End With
        Next
        With .Cells(1).CurrentRegion
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .VerticalAlignment = xlCenter
            With .Rows(1)
                .HorizontalAlignment = xlCenter
                .BorderAround Weight:=xlThin
                .Interior.Color = 44522
                With .Cells(4).Resize(, 4)
                    .HorizontalAlignment = xlCenterAcrossSelection
                    .Interior.Color = 6740479
                End With
            End With
            .Columns.AutoFit
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour et merci pour ton aide,

Ton code fonctionne parfaitement, mieux que le mien vu qu'il répond à tous mes problèmes. J'ai pas encore tout compris de son fonctionnement.

J'ai quelques petites questions par rapport aux boucles:

1) Suivant l'organe que je choisi, il y a plus ou moins de colonnes, cela va de 3-4 au mini à 8-9 pour les plus grandes. Serait-il possible de boucler suivant le nombre de colonne ? Ou faut-il copié collé le code pour l'adapter à chaque cas?

2) Lors de la création de la feuille je souhaiterai la nommer d'une certaine façon et ne pas la créer si elle existe.

Set f1 = Sheets("Feuille transition inventaire")

critère = f1.Range("aa1")

Feuille_Existe = False

For Each Feuille In Worksheets
    If Feuille.Name = critère & " INV" Then
        Feuille_Existe = True
    End If
Next Feuille

If Feuille_Existe = False Then
    Sheets.Add(After:=f1).Name = critère & " INV"   'cette méthode fonctionne
End If

Ceci est un code que j'avais testé pour ce problème, il fonctionne mais je ne sais pas si je pourrais le rajouter à ton code juste avant la création de la feuille. Cela me permettrait de ne pas créer une nouvelle feuille à chaque fois.

3) Est ce que tu pourrais rajouter des commentaires sur à quoi servent les boucles ( pas forcément pour chaque ligne mais l'idée générale plutôt) si ce n'est pas trop te demander?

En tout cas merci beaucoup pour ton aide

Bonne semaine

Re Mending,

Le code réajusté :

Option Explicit
Sub test()
    Dim a, w(), x(), i As Long, j As Byte, n As Long, txt As String, e, s, dico As Object
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Exemple").Cells(1).CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 3)) Then
            Set dico(a(i, 3)) = CreateObject("Scripting.Dictionary")
            dico(a(i, 3)).CompareMode = 1
        End If
        txt = ""
        For j = 4 To UBound(a, 2) - 1
            txt = txt & a(i, j) & "|"
        Next
        txt = Left(txt, Len(txt) - 1)
        If Not dico(a(i, 3)).exists(txt) Then
            ReDim w(1 To 3): ReDim x(1 To UBound(a, 2) + 1)
            Set w(1) = CreateObject("Scripting.Dictionary")
            w(1).CompareMode = 1
            Set w(2) = CreateObject("Scripting.Dictionary")
            w(2).CompareMode = 1
            For j = 3 To UBound(a, 2) - 1
                x(j) = a(i, j)
            Next
            w(3) = x
            dico(a(i, 3))(txt) = w
        End If
        w = dico(a(i, 3))(txt)
        If Not w(1).exists(a(i, 1)) Then
            w(1)(a(i, 1)) = Empty
            w(3)(1) = w(3)(1) & IIf(w(3)(1) <> "", "|", "") & a(i, 1)
        End If
        If Not w(2).exists(a(i, 2)) Then
            w(2)(a(i, 2)) = Empty
            w(3)(2) = w(3)(2) & IIf(w(3)(2) <> "", "|", "") & a(i, 2)
        End If
        w(3)(UBound(w(3)) - 1) = w(3)(UBound(w(3)) - 1) + a(i, UBound(a, 2))
        w(3)(UBound(w(3))) = w(3)(UBound(w(3))) & IIf(w(3)(UBound(w(3))) <> "", "|", "") & i
        dico(a(i, 3))(txt) = w
    Next
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("restitution").Delete
    Sheets.Add().Name = "restitution"
    On Error GoTo 0
    With Sheets("restitution")
        With .Cells(1).Resize(, UBound(a, 2) + 1)
            .Value = Application.Index(a, 1, 0)
            .Cells(.Cells.Count).Value = "Fusion"
        End With
        n = 2
        For Each e In dico.keys
            For Each s In dico(e).keys
                With .Cells(n, 1).Resize(1, UBound(dico(e)(s)(3), 1))
                    .Value = dico(e)(s)(3)
                End With
                n = n + 1
            Next
            With .Cells(n, 1).Resize(1, UBound(a, 2) + 1)
                .Borders(xlEdgeTop).Weight = xlThin
            End With
        Next
        With .Cells(1).CurrentRegion
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .VerticalAlignment = xlCenter
            With .Rows(1)
                .HorizontalAlignment = xlCenter
                .BorderAround Weight:=xlThin
                .Interior.Color = 44522
                With .Cells(4).Resize(, UBound(a, 2) - 4)
                    .HorizontalAlignment = xlCenterAcrossSelection
                    .Interior.Color = 6740479
                End With
            End With
            With .Columns(.Columns.Count)
                .NumberFormat = "@"
                .HorizontalAlignment = xlCenter
            End With
            .Columns.AutoFit
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89