Transposer colonne multiple vers lignes multiples

Bonjour à tous,

Je viens vers vous pour savoir s'il existait une solution permettant de renverser un tableau originellement construit en colonne, pour un transposage vers une structure en ligne. (fichier en pièce jointe).

Le tableau recense des "elements" par catégorie. Chaque "element" a 5 variables

Le tableau à la base donnait : la catégorie, l'élément dans cette catégorie, et les 5 variables selon cette structure

categ 1

element 1

var a

var b

var c

var d

var e

element 2

var a

var b

var c

var d

var e

le tableau peut comprendre 3+ catégories et plusieurs dizaines d'éléments par catégorie.

J'aimerais basculer sur cela :

categ 1 | element 1 | var a | var b | var c | var d | var e

categ 1 | element 2 | var a | var b | var c | var d | var e

categ 2 | element 1 | .....

Si une solution existe, je suis preneur.

Merci par avance pour les retours.

A titre indicatif, j'utilise déjà ce types de codes pour restructurer des tableaux colonnes vers lignes, je n'arrive juste pas à voir comment coder ce nouveau problème :

Pour transposer categ 1 avec element 1-2-3 etc... : crédits LouReed, Machin, Jean-Eric, Klin89,

Sub normaliser_()

Dim myAreas As Areas, myArea As Range, i As Long, n As Long, b()
    'attention à la dimension
   ReDim b(1 To 1000, 1 To 3)
    With Sheets("Feuil1")
        With .Range("c1", .Range("c" & Rows.Count).End(xlUp))
            On Error Resume Next
            Set myAreas = .SpecialCells(2, 1).Areas
            On Error GoTo 0
            If myAreas Is Nothing Then Exit Sub
            For Each myArea In myAreas
                For i = 1 To myArea.Rows.Count
                    n = n + 1
                    b(n, 1) = myArea.Cells(1)(0, 0)
                    b(n, 2) = myArea.Cells(i)(1, 0)
                    b(n, 3) = myArea.Cells(i)
                Next
            Next
            Set myAreas = Nothing
            With .Offset(, .Columns.Count + 1).Resize(n, UBound(b, 2))
                .CurrentRegion.Cells.Clear
                .Value = b
                .Columns.ColumnWidth = 17
            End With
        End With
    End With
End Sub

Pour passer d'une matrice carré vers un listing en liste de correspondance , crédits : R@chid, h2so4,

Sub Transpose_fonction_arcs()

Call blank_space 'vient placer les 0 dans le tableau pour ensuite créer la table des liens fonctions_fonctions

    Dim Tbl()
    Dim I As Integer 
    'appel de la fonction
   Tbl() = TransposeGrille(Range("U1:AH14"))
    'inscrit à partir de C20. Attention, les titres ne sont pas inscrits (Item1 et Item2)
   Range("U16").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 <> 0 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

Merci,

F.

Je vais m'auto-répondre avec ce thread...

Le problème est le même, la macro à ajuster cela dit.

https://forum.excel-pratique.com/excel/transposer-plusieurs-tableaux-en-lignes-vers-des-colonnes-t57608.html

A priori cette macro permet de répondre à la question, même si mon tableau initial n'a pas la même forme au départ.

La macro fait le travail de transposer des références + valeurs en ligne successives qui se répètent selon un schéma (toutes les 4 lignes), en colonne.

Pour ceux qui cherchait une solution, je fais remonter au cas où.

Merci à Jean-Eric.

G.

Bonjour Pwetzou, le forum

Sans conviction 8)

Option Explicit

Sub test()
Dim a, b(), i As Long, j As Long, n As Long, t As Byte, txt As String
    With Sheets("Feuil1").Range("b3").CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 2)
        n = 1
        For i = 1 To UBound(a, 1)
            If Left(a(i, 1), 5) = "categ" Then
                txt = a(i, 1)
            Else
                If Left(a(i, 1), 7) = "element" Then
                    t = 2: n = n + 1
                    b(n, 1) = txt
                    b(n, 2) = a(i, 1)
                Else
                    t = t + 1
                    If UBound(b, 2) < t Then
                        ReDim Preserve b(1 To UBound(b, 1), 1 To t)
                    End If
                    If n = 2 Then b(1, t) = a(i, 1)
                    b(n, t) = a(i, 2)
                End If
            End If
        Next
        With .Offset(, .Columns.Count + 1).Resize(n, UBound(b, 2))
            .CurrentRegion.ClearContents
            .Value = b
        End With
    End With
    'Sheets("feuil2").Cells(1).Resize(n, UBound(b, 2)) = b
End Sub

Attention aux espaces invisibles notamment en B2

klin89