Transformer mon tableau

bonsoir,
j’ai un grand tableau et je voudrait réaranger les données d’une autre manière.

comme dans le fichier joint

tableau.xlsx (9,8 Ko)

je suis novice et un peu paumé
si quelqu’un peut m’aider à le faire en automatique…
merci à tous

Bonjour,

Un petit peu Ardu avec les cellules fusionnées, surtout que les blocs ne sont pas identiques

La Procédure:

Option Explicit
Dim NbLig%, l%, c%, i%, j%, Nbcol%, Dl%, art%           'Déclaration des variables
Sub Transposer()
  Range("H6").CurrentRegion.Clear                       'Efface l'ancien tableau transposé
  
  'ARTICLE
  Range("B2").Select
  Range(Selection, Selection.End(xlDown)).Copy          'Sélection de la colonne B
  Range("D1").Select                                    'copie sur colonne D
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
  ActiveSheet.Range(Selection, Selection.End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
  Range("D1").Select                                    'Supprime les doublons
  NbLig = Range(Selection, Selection.End(xlDown)).Count 'Mémorise le Nb de ligne dans variable
  Range(Selection, Selection.End(xlDown)).Copy          'Sélectionne les valeurs colonne D
  Range("I6").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
  Columns("D:D").Clear                                  'Colle les données en I6 en les tranposant en horizontal et efface colonne D
  Nbcol = NbLig                                         'Attribue le Nb ligne à la variable Nbcol (Nb colonne)
  l = 7: c = 8
  
  'BOITE
  Range("A2").Select
  NbLig = Range("A2").MergeArea.Cells.Count             'Récupère le Nb ligne pour le 1er bloc fusionné
  Cells(l, c) = ActiveCell.Value                        'colle les données dans le nouveau tableau
  l = l + 1
    While Selection.Offset(1, 0) <> ""                  'Effectue une boucle sur tous les blocs fusionnés pour les coller à la suite
      Selection.Offset(1, 0).Select
      Cells(l, c) = ActiveCell.Value
      l = l + 1
    Wend
  
  Dl = Range("B" & Rows.Count).End(xlUp).Row            'Dernière ligne colonne B
    Columns("A:A").Select                               'Sélectionne la colonne A et défusionne les blocs
    Selection.UnMerge
    Range("A2").Select
    For i = 2 To Dl
      If Cells(i, 1).Value = "" Then
        Cells(i, 1) = Cells(i - 1, 1)
      End If
    Next i
  
  'QUANTITE
  
  Range("I7").Select                                    'Effectue une triple boucle pour remettre les données dans le nouveau tableau
  For art = 9 To Nbcol + 8
    For j = 7 To NbLig + 6
      For i = 2 To Dl
        If Cells(i, 1).Value = Cells(j, 8).Value And _
          Cells(i, 2).Value = Cells(6, art).Value Then
          Cells(j, art).Value = Cells(i, 3).Value
        End If
      Next i
    Next j
  Next art
  MiseEnForme                                           'Exécute la macro MiseEnForme pour le centrage et le quadrillage
End Sub

Sub MiseEnForme()
    Range(Cells(6, 8), Cells(6, 8).Offset(NbLig, Nbcol)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With
    Range("H6").Select
End Sub

Le Classeur

tableau.xlsm (20,8 Ko)

1 « J'aime »

merci pour la réponse, mais franchement j’ai rien compris.
comment faire pour transposer cette macro sur mon tableau qui doit faire un bon millier de ligne.

Re,

D’où le principe de mettre en PJ un exemple concret et qui soit au même endroit :grinning:

La solution, soit mettre ton tABLEAU en PJ, si trop confidentielle me le passer en Message privé

ok, je vois ça lundi et te tiens au courant
merci beaucoup:grinning:

Avoir une assistance c’est mieux je crois