Excel - Transposition de lignes

Le
scrmbl
Bonjour,

Voici le problème :

J'ai un tableau du type :

Fourn. - FD00 - FD01 - FD02 - FD03 - - FD30
40401..15 ..1617..18..12
40402..13.11..10.. 9.. 24
40403.14.192. 717
40404..1511..161812


41400

J'ai environ 1000 lignes et 30 colonnes. Ce tableau se situe dans une "Feuil1", et j'aimerais le transposer dans la "Feuil2" de la façon suivante :

Fourn. Rubrique Valeur

40401 FD00 15
40401 FD01 16
40401 FD02 17
40401 FD03 18
40402 FD00 13


J'ai pensé à coder une Macro en VBA, mais ne connaissant pas du tout ce langage, je suis relativement perdu.

Pour le moment, j'ai trouvé quelque chose de ce type :
'--'
Sub test()

Dim Rg As Range, R As Range
Dim Col As Integer, Ligne As Long

On Error Resume Next

With Feuil1
Set Rg = .Range("A2:A" & .Range("A6556").End(xlUp).Row)
End With

Ligne = 1
For Each R In Rg.Rows
Col = R.EntireRow.Cells.Find("*", LookIn:=xlValues, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column

With Feuil2
.Range("A" & Ligne).Resize(Col - 1) = _
R.Cells(1, 1).Value
.Range("C" & Ligne).Resize(Col - 1) = _
Application.Transpose(R.Offset(, 1). _
Resize(, Col - 1).Value)
Ligne = Ligne + Col - 1
End With


Next
End Sub

'--'

Mes lignes sont bien transposées, par contre je ne sais pas comment modifier la chose de façon à transposer également mes rubriques.

Merci d'avance pour votre aide.

Cdt.

N.
Questions / Réponses high-tech
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
StephD
Le #19673671
Bonjour,

Avec un truc comme ceci

Option Explicit

Sub MaTranspo()

Dim DerLig#, DerCol#
Dim i#, j#, k#
Dim mesdonnees

Application.DisplayAlerts = False: Application.ScreenUpdating =
False

With ActiveSheet
DerLig = .[A65536].End(3).Row
DerCol = .[IV1].End(1).Column
ReDim mesdonnees(1 To (DerLig * DerCol), 1 To 3)
For i = 2 To DerLig
For j = 2 To DerCol
k = k + 1
mesdonnees(k, 1) = .Cells(i, 1)
mesdonnees(k, 2) = .Cells(1, j)
mesdonnees(k, 3) = .Cells(i, j)
Next j
Next i
End With
On Error Resume Next: Sheets("Résultat").Delete: On Error GoTo 0
Sheets.Add(after:¬tiveSheet).Name = "Résultat"

With Sheets("Résultat")
.[A1].Resize(UBound(mesdonnees, 1), UBound(mesdonnees, 2)) =
mesdonnees
.Rows("1:1").Insert
.[A1] = "Fourn.": .[B1] = "Rubrique": .[C1] = "Valeur"
End With

Application.DisplayAlerts = True: Application.ScreenUpdating =
True

End Sub
Publicité
Poster une réponse
Anonyme