Mettre sur la même ligne des lignes contenant des cellules identiques

[ladiagdufou]

Bonjour à toutes et à tous,

Je suis nouveau en VBA et ça fait maintenant 2 jours que je recherche une solution à un problème tout simple je pense.

J'ai un tableau contenant plusieurs commandes aligner les unes en dessous des autres. La colonne A représente des N° de commande. Mais la commande N°X Peut avoir plusieurs produits. Ces commandes sont placer les unes sous les autres. Je veux que les commandes identiques soient sur la même ligne.

J'ai joint un fichier excel très explicite.

Merci d’avance pour vos suggestions, pistes et du temps que vous m'aurez consacré.

 

[Modeste]

Re : Mettre sur la même ligne des lignes contenant des cellules identiques

Bonjour ladiagdufou (un hommage au film?) et bienvenue,

Tu n'as pas idée du nombre de discussions dont l'auteur affirmait au départ "ce doit être tout simple" 😉

Si les données sont triées sur le n° de commande (en colonne A de la "Feuille d'origine") et que les titres figurent déjà en colonne A à O de la "Feuille triée", tu peux tester le code suivant, en le copiant dans un module standard:

Sub grouper()
Application.ScreenUpdating = False
Sheets("Feuille triée").[A2].Resize(Sheets("Feuille triée").UsedRange.Rows.Count, 15).Clear
Set src = Sheets("Feuille d'origine")
With Sheets("Feuille triée")
ligne = .Cells(Rows.Count, 1).End(xlUp).Row + 1
For Each c In src.Cells(2, 1).Resize(src.Cells(Rows.Count, 1).End(xlUp).Row - 1, 1)
    If c <> c.Offset(-1, 0) Then
        .Cells(ligne, 1).Resize(1, 5).Value = c.Resize(1, 5).Value
        trouve = True
        col = 0
    Else
        col = col + 5
        .Cells(ligne - 1, 1).Offset(0, col).Resize(1, 5).Value = c.Resize(1, 5).Value
    End If
    If trouve Then ligne = ligne + 1: trouve = False
Next c
End With
Application.ScreenUpdating = True
End Sub

Si le volume des données est nettement plus conséquent que dans ton exemple, il faudra vérifier si le temps d'exécution n'est pas trop long. Si c'est le cas, reviens nous le dire.

 

[ladiagdufou]

Re : Mettre sur la même ligne des lignes contenant des cellules identiques

Bonjour Modeste,

Comment te dire que je te remercie infiniment ?

En effet, mon speudo est notamment un hommage au filme la Diagonale du Fou.

 

[klin89]

Re : Mettre sur la même ligne des lignes contenant des cellules identiques

Bonsoir ladiagdufou, Modeste, le forum 🙂

A tester sur PC :
Attention à l'ordre des feuilles.
Résultat dans la 2ème feuille.

Sub transpose()
Dim a, i As Long, e, maxCol As Long, y, n As Long
    Application.ScreenUpdating = False
    With Sheets(1).Range("a1").CurrentRegion.Resize(, 5)
        With .Offset(1).Resize(.Rows.Count - 1)
            a = .Value
        End With
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then .Item(a(i, 1)) = Empty
                If IsEmpty(.Item(a(i, 1))) Then
                    ReDim w(1 To 5)
                Else
                    w = .Item(a(i, 1))
                    ReDim Preserve w(1 To UBound(w) + 5)
                End If
                w(UBound(w) - 4) = a(i, 1)
                w(UBound(w) - 3) = a(i, 2)
                w(UBound(w) - 2) = a(i, 3)
                w(UBound(w) - 1) = a(i, 4)
                w(UBound(w)) = a(i, 5)
                .Item(a(i, 1)) = w
                maxCol = Application.Max(maxCol, UBound(w))
            Next
            For Each e In .keys
                w = .Item(e)
                ReDim Preserve w(1 To maxCol)
                .Item(e) = w
            Next
            y = .items: n = .Count
        End With
        With Sheets(2).Cells(1)
            .CurrentRegion.Clear
            Sheets(1).Range("A1:E1").Copy .Resize(, maxCol)
            .Offset(1).Resize(n, maxCol).Value = _
            Application.transpose(Application.transpose(y))
            With .CurrentRegion
                .Columns.AutoFit
                .BorderAround ColorIndex:=1, Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Name = "calibri"
                .Font.Size = 10
                With .Rows(1)
                    .Interior.ColorIndex = 41
                    .Font.ColorIndex = 2
                    .Font.Size = 11
                    .RowHeight = 20
                    .BorderAround ColorIndex:=1, Weight:=xlThin
                End With
                For i = 1 To maxCol Step 5
                    .Cells(1, i).Resize(1, 5).BorderAround Weight:=xlMedium
                    .Cells(1, i).Resize(n + 1, 5).BorderAround Weight:=xlMedium
                Next i
                .Parent.Activate
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[ladiagdufou]

Re : Mettre sur la même ligne des lignes contenant des cellules identiques

Bonjour klin89,

Je te remercie beaucoup de ta disponibilité ! Cependant, le code ne fonctionne pas, probablement parce que je suis sur MAC. Par ailleurs, le code de Modeste fonctionne très bien sur ma machine.

Merci encore.