Transposer une matrice "carrée" en liste absolue

Bonjour à tous,

Je recherche un code qui me permettrait de transposer la grille "1" vers la grille "1 prime", en un seul widget.

Pour l'instant le code m'intéresse d'avantage que le widget.

L'emplacement de destination n'a pas d'importance (même feuille suffit), mais seul le format de liste en sortie importe.

Dans la matrice "1", de type binaire, on a un item 1 corrélé à un item 2. La corrélation existe ou n'existe pas.

Je souhaiterais transposer cette matrice en une liste verticale faisant état de l'ensemble des corrélations possibles pour tous les items 1 :

- Si l'item 1 "A" a une corrélation avec alpha, beta et gamma, alors j'écris 3fois "A" et je mets en face alpha, beta, gamma,

etc...

- Annexe : Si possible, je souhaiterais également pouvoir trouver un code permettant de faire le retour vers la matrice, à partir d'une liste, donc pouvoir l'aller, et le retour.

Note : le nombre d'item 1 et d'item 2 est aléatoire. le nombre de corrélations maximum pour un item 1 vaut à la population des items 2.

Note bis : le fichier exemple en joint.

Je vous remercie par avance pour vos retours, je continue à plancher sur la question.

Merci à tous,

Cdt,

G.

Bonjour,

Une piste avec une fonction. Les titres ne sont pas retournés par la fonction car Item2 est pour ainsi dire hors tableau. Il peuvent être entrés manuellement. Exécuter la Sub Test en ayant au préalable adapter la plage de recherche et la cellule devant recevoir le tableau renvoyé :

Sub Test()

    Dim Tbl()
    Dim I As Integer

    'appel de la fonction
    Tbl() = TransposeGrille(Range("B2:E9"))

    'inscrit à partir de C20. Attention, les titres ne sont pas inscrits (Item1 et Item2)
    Range("C20").Resize(UBound(Tbl, 1), UBound(Tbl, 2)) = Tbl

End Sub

Function TransposeGrille(Plage As Range) As Variant() 'la fonction retourne un tableau

    Dim Tbl()
    Dim Cel As Range
    Dim I As Long
    Dim J As Long

    For Each Cel In Plage.Columns(1).Cells

        For I = 1 To Plage.Columns.Count - 1

            If Cel.Offset(, I).Value = 1 Then

                J = J + 1
                ReDim Preserve Tbl(1 To 2, 1 To J)

                Tbl(1, J) = Cel.Value
                Tbl(2, J) = Plage(1, 1 + I).Value

            End If

        Next I

    Next Cel

    TransposeGrille = Application.WorksheetFunction.Transpose(Tbl())

End Function

Hervé.

Ca marche génial.

Juste à adapter la cellule cible de sortie des résultats ainsi que la plage à traiter..

J'ai rajouté un code pour remplir les cellules vides de la plage par des 0 et c'est niquel.

Connaitrais-tu par hasard un code pour produire le chemin exactement inverse, à partir de la liste, reproduire la matrice ?

Merci beaucoup Hervé,

Bien cordialement,

G.

Bonjour,

Connaitrais-tu par hasard un code pour produire le chemin exactement inverse, à partir de la liste, reproduire la matrice ?

Là par contre, ça ma donné du fil à retordre. Il y a sûrement plus simple mais pour le moment je ne vois pas. J'ai utilisé des dictionnaires afin de pouvoir récupérer les entêtes de linges et colonnes :

Sub TestInverse()

    Dim Tbl()
    Dim I As Integer

    'appel de la fonction
   Tbl() = TransposeGrilleInverse(Range("C21:D31"))

   Range("G2").Resize(UBound(Tbl, 1), UBound(Tbl, 2)) = Tbl

End Sub

Function TransposeGrilleInverse(Plage As Range) As Variant() 'la fonction retourne un tableau

    Dim DicoLgn As Object
    Dim DicoCol As Object
    Dim ElementLgn
    Dim ElementCol
    Dim Tbl()
    Dim Cel As Range
    Dim I As Long
    Dim J As Long
    Dim Adr As String

    Set DicoLgn = CreateObject("Scripting.Dictionary")
    Set DicoCol = CreateObject("Scripting.Dictionary")

    'détermine le nombre de lignes
    For Each Cel In Plage.Columns(1).Cells

        If DicoLgn.exists(Cel.Value) = False Then DicoLgn.Add Cel.Value, Cel.Value

    Next Cel

    'détermine le nombre de colonnes
    For Each Cel In Plage.Columns(2).Cells

        If DicoCol.exists(Cel.Value) = False Then DicoCol.Add Cel.Value, Cel.Value

    Next Cel

    'dimentionne le tableau
    ReDim Tbl(1 To DicoLgn.Count + 1, 1 To DicoCol.Count + 1)

    'défini les éléments
    ElementLgn = DicoLgn.Items
    ElementCol = DicoCol.Items

    'ajoute au tableau les entêtes de lignes
    For I = 0 To DicoLgn.Count - 1

        Tbl(I + 2, 1) = ElementLgn(I)

    Next I

    'ajoute au tableau les entêtes de colonnes
    For I = 0 To DicoCol.Count - 1

        Tbl(1, I + 2) = ElementCol(I)

    Next I

    'effectue la criblage
    For I = 1 To DicoLgn.Count

        Set Cel = Plage.Columns(1).Find(ElementLgn(I - 1), , xlValues, xlWhole)

        Adr = Cel.Address

        Do

            For J = 1 To DicoCol.Count

                If Cel.Offset(, 1).Value = ElementCol(J - 1) Then
                    Tbl(I + 1, J + 1) = 1
                Else
                    If Tbl(I + 1, J + 1) <> 1 Then Tbl(I + 1, J + 1) = 0
                End If

            Next J

            Set Cel = Plage.FindNext(Cel)

        Loop While Cel.Address <> Adr

    Next I

    TransposeGrilleInverse = Tbl()

End Function

Hervé.

Puissant...

Je teste ça sur 2000 lignes et 2000 colonnes et je te dis si cela tourne toujours 8) .

Merci beaucoup Hervé !

a+.