Microsoft 365 Modification de tableaux : transposition de lignes en colonnes sous chaque ligne

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

oakd

XLDnaute Nouveau
Bonjour à tous,

Je sollicite votre aide pour modifier la disposition de tableaux :
  • transposer en colonne des lignes situées en fin de tableau et les placer sous chaque ligne
  • étendre vers le bas les données des autres colonnes
Ci-joint un exemple pour bien comprendre. Je ne sais pas s’il est obligatoire de créer une macro ou si c’est faisable avec un outil comme Kutools (pour ceux qui connaissent).

Le but final est d’avoir un tableau où l’on puisse trier les données.
 

Pièces jointes

Bonjour

Faisable par PowerQuery intégré à Excel
VB:
let
    Source = Excel.CurrentWorkbook(){[Name="Tableau1"]}[Content],
    PStep = Table.UnpivotOtherColumns(Source, List.FirstN(Table.ColumnNames(Source), 34), "Article", "Prix"),
    Reorder = Table.ReorderColumns(PStep,List.Combine({List.FirstN(Table.ColumnNames(PStep), 4),{"Article","Prix"},List.FirstN(List.LastN(Table.ColumnNames(PStep),List.Count(Table.ColumnNames(PStep))-4),30)}))
in
    Reorder

Si la source évolue, Données, Actualiser tout
 

Pièces jointes

Dernière édition:
Bonjour @oakd, @chris 🙂,

Une version par VBA. La feuille du résultat "Result" est mise à jour chaque fois qu'on l'active.
Le code est dans le module de la feuille "Result" :
VB:
Private Sub Worksheet_Activate()
Dim t, i&, j&, n&, ref&
   Application.ScreenUpdating = False
   t = Sheets("Feuil1").Range("a2").ListObject.Range
   ReDim r(1 To UBound(t) * (UBound(t, 2) - 34), 1 To 3)
   For i = 2 To UBound(t)
      For j = 35 To UBound(t, 2)
         If t(i, j) <> "" Then
            n = n + 1
            r(n, 1) = t(1, j)
            r(n, 2) = t(i, j)
            r(n, 3) = i
         End If
      Next j
   Next i
   On Error Resume Next: Range("a1").ListObject.Delete: Range("a1").CurrentRegion.Delete: On Error GoTo 0
   For j = 1 To 4: Cells(1, j) = t(1, j): Next
   Cells(1, 5) = "Articles": Cells(1, 6) = "Prix"
   For j = 5 To 34: Cells(1, j + 2) = t(1, j): Next
   Range("e2").Resize(n, 2) = r
   For i = 1 To n
      If r(i, 3) <> ref Then
         For j = 1 To 4: Cells(i + 1, j) = t(r(i, 3), j): Next
         For j = 5 To 34: Cells(i + 1, j + 2) = t(r(i, 3), j): Next
         ref = r(i, 3)
      End If
   Next i
   Range("a1").Resize(n + 1, 36).SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
   Range("a1").Resize(n + 1, 36).Value = Range("a1").Resize(n + 1, 36).Value
   Me.ListObjects.Add(xlSrcRange, Range("a1").Resize(n + 1, 36), , xlYes).Name = "TabRes"
End Sub
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
9
Affichages
367
Retour