Réorganiser des cellules selon un autre type de tri

Bonjour à tous,

J'ai un soucis qui semble tout simple à gérer mais je me casse les dents pour trouver une solution...

J'ai un tableau dans la feuille "liste intervention" qui recense des interventions au fur et à mesures qu'elles sont effectuées.

Disons ici qu'il s'agit de tests effectués sur différents produits.

Une intervention ne concerne qu'un produit mais un produit peut se retrouver dans plusieurs interventions

je voudrais dans la feuille "résumé produit" avoir un tableau résumant l'état de chaque test mais par produit.

j'ai essayé avec la formule

=INDEX('liste intervention'!D2:D14,MATCH(B2,'liste intervention'!C2:C14,0),MATCH(B1,'liste intervention'!B2:B14,0))

Mais sans reussite. avec un Vlookup cela ne donne rien non plus.

Si quelqu'un pouvait me donner une piste ou un petit coup de pouce ce serait top top !

Je vous joins le fichier exemple qui sera surement plus clair que mes explications

Merci D'avance pour votre aide

Alex.

Bonsoir Alex_Luthor, le forum,

A tester :

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, t As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("liste intervention").Range("a1").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To 2)
    n = 1: t = 1: b(n, t) = "Produit"
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 3)) Then
                n = n + 1: dico(a(i, 3)) = n
                b(n, 1) = a(i, 3)
            End If
            If Not .exists(a(i, 2)) Then
                t = t + 1: .Item(a(i, 2)) = t
                If t > UBound(b, 2) Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 10)
                End If
                b(1, t) = a(i, 2)
            End If
            b(dico(a(i, 3)), .Item(a(i, 2))) = a(i, 4)
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets.Add().Cells(1).Resize(n, t)
        .Value = b
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .BorderAround Weight:=xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        With .Rows(1)
            .BorderAround Weight:=xlThin
            With .Offset(, 1).Resize(, .Columns.Count - 1)
                .Interior.ColorIndex = 36
            End With
        End With
        With .Columns(1)
            With .Offset(1).Resize(.Rows.Count - 1)
                .Interior.ColorIndex = 38
            End With
        End With
        '.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour Klin89,

Merci beaucoup ça marche parfaitement, je pensais à créer des tableaux "intermédiaires" mais ta solution est beaucoup plus simple car le fichier de suivi sur lequel je travaille et bien plus imposant que le fichier exemple

Merci encore.

Alex.

re Alex_Luthor

Pour le fun, tu peux remplir ton tableau directement comme ceci :

Option Explicit
Sub ventile()
Dim a, i As Long, j As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("liste intervention").[a1].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
        dico(a(i, 3))(a(i, 2)) = a(i, 4)
    Next
    Application.ScreenUpdating = False
    With Sheets("Resumé produit").[a1].CurrentRegion
        With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
            .ClearContents
        End With
        For i = 2 To .Rows.Count
            If dico.exists(.Cells(i, 1).Value) Then
                For j = 2 To .Columns.Count
                    If dico(.Cells(i, 1).Value).exists(.Cells(1, j).Value) Then
                        .Cells(i, j).Value = dico(.Cells(i, 1).Value)(.Cells(1, j).Value)
                    End If
                Next
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

klin89