Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

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

  • fichier exemple.xlsx
    33.1 KB · Affichages: 9

chris

XLDnaute Barbatruc
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

  • Décroiser_Ordonner_PQ.xlsx
    36.3 KB · Affichages: 2
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
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

  • oakd- fichier exemple- v1.xlsm
    24.6 KB · Affichages: 4

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…