Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Transposer des colonnes en lignes

Transposer des colonnes en lignes

4 réponses
Avatar
Sylvain P.
Bonjour,

J'ai une feuille Excel avec des donn=E9es disposer de la fa=E7on
suivante :
Entreprise1 Nom1 Nom2 Nom 3
Entreprise2 Nom1 Nom2
Entreprise2 Nom1 Nom2 Nom3 Nom4
...

J'aimerai transposer les colonnes avec les donn=E9es Nom en lignes pour
obtenir un tableau de la sorte :
Entreprise1 Nom1
Entreprise1 Nom2
Entreprise1 Nom 3
Entreprise2 Nom1
Entreprise2 Nom2
Entreprise2 Nom 3
Entreprise2 Nom 4
...


J'ai =E9crit le code suivant. Mais ce n'est pas tr=E8s performant.

Range("A1").Select
Dim LastCell 'Derni=E8re cellule au croisement
Dim Plage1 ' Plage D1:Derni=E8re cellule
Dim Plage2 ' Plage C1:Derni=E8re cellule

Cells(Cells.Find("*", SearchOrder:=3DxlByRows,
SearchDirection:=3DxlPrevious).Row, Cells.Find("*",
SearchOrder:=3DxlByColumns, SearchDirection:=3DxlPrevious).Column).Select
Set LastCell =3D Selection
Range("E" & LastCell.Row).Select
Range(Selection, Cells(5)).Select
Set Plage1 =3D Selection

For Each c In Plage1
If c.Value <> 0 Then
Range("A" & c.Row).EntireRow.Select
Selection.Insert Shift:=3DxlDown
c.EntireRow.Copy
Range("A" & c.Row - 1).EntireRow.Select
ActiveSheet.Paste
Range("e" & c.Row - 1).Copy
Range("D" & c.Row).Select
ActiveSheet.Paste
Range("e" & c.Row - 1).ClearContents
Range("e" & c.Row).ClearContents

End If
Next


Auriez-vous des conseils, des id=E9es ?
Merci par avance.

A+
Signaler un problème avec ce contenu

4 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
FFO
Salut Sylvain

Soit la Feuil1 à traiter
Soit en Feuil2 le résultat colonne A/B à partir de la ligne 2

Je te propose ce code :

Sheets("Feuil2").Range("A2", "B" &
Sheets("Feuil2").Range("B65535").End(xlUp).Row).Clear
i = 2
Do While i < Sheets("Feuil1").Range("A65535").End(xlUp).Offset(1, 0).Row
If Sheets("Feuil1").Range("A" & i - 1) <> Sheets("Feuil1").Range("A" & i) Then
Donnée = ""
For Each c In Worksheets("Feuil1").Range("B" & i,
Sheets("Feuil1").Range("IV" & i).End(xlToLeft).Address)
Sheets("Feuil2").Range("A65535").End(xlUp).Offset(1, 0) =
Sheets("Feuil1").Range("A" & i)
Sheets("Feuil2").Range("A65535").End(xlUp).Offset(0, 1) = c
Donnée = Donnée & "/" & c
Next
Else
For Each d In Worksheets("Feuil1").Range("B" & i,
Sheets("Feuil1").Range("IV" & i).End(xlToLeft).Address)
If Donnée Like "*" & d & "*" = False Then
Sheets("Feuil2").Range("A65535").End(xlUp).Offset(1, 0) =
Sheets("Feuil1").Range("A" & i)
Sheets("Feuil2").Range("A65535").End(xlUp).Offset(0, 1) = d
Donnée = Donnée & "/" & c
End If
Next
End If
i = i + 1
Loop

Sur ce lien un exemple

http://www.cijoint.fr/cjlink.php?file=cj200904/cijM1YJWui.xls

Actives Feuil1 le bouton "Traitement"

Fais des essais et dis moi !!!!!
Avatar
michdenis
Bonjour Sylvain,

La procédure prend les valeurs de la Feuille "Feuil1"
et les transpose dans la feuille "Feuil2"

à copier dans un module standard

'------------------------------------------
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("A1: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("B" & Ligne).Resize(Col - 1) = _
Application.Transpose(R.Offset(, 1). _
Resize(, Col - 1).Value)
Ligne = Ligne + Col - 1
End With

Next
End Sub
'------------------------------------------





"Sylvain P." a écrit dans le message de
news:
Bonjour,

J'ai une feuille Excel avec des données disposer de la façon
suivante :
Entreprise1 Nom1 Nom2 Nom 3
Entreprise2 Nom1 Nom2
Entreprise2 Nom1 Nom2 Nom3 Nom4
...

J'aimerai transposer les colonnes avec les données Nom en lignes pour
obtenir un tableau de la sorte :
Entreprise1 Nom1
Entreprise1 Nom2
Entreprise1 Nom 3
Entreprise2 Nom1
Entreprise2 Nom2
Entreprise2 Nom 3
Entreprise2 Nom 4
...


J'ai écrit le code suivant. Mais ce n'est pas très performant.

Range("A1").Select
Dim LastCell 'Dernière cellule au croisement
Dim Plage1 ' Plage D1:Dernière cellule
Dim Plage2 ' Plage C1:Dernière cellule

Cells(Cells.Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row, Cells.Find("*",
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column).Select
Set LastCell = Selection
Range("E" & LastCell.Row).Select
Range(Selection, Cells(5)).Select
Set Plage1 = Selection

For Each c In Plage1
If c.Value <> 0 Then
Range("A" & c.Row).EntireRow.Select
Selection.Insert Shift:=xlDown
c.EntireRow.Copy
Range("A" & c.Row - 1).EntireRow.Select
ActiveSheet.Paste
Range("e" & c.Row - 1).Copy
Range("D" & c.Row).Select
ActiveSheet.Paste
Range("e" & c.Row - 1).ClearContents
Range("e" & c.Row).ClearContents

End If
Next


Auriez-vous des conseils, des idées ?
Merci par avance.

A+
Avatar
gmlsteph
Bonjour,

Sub avz()
Dim c As Range, lig As Long
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "zaza"

For lig = 1 To Feuil1.[a65536].End(xlUp).Row
For Each c In Feuil1.Rows(lig).Cells
If c.Column > 1 Then
If IsEmpty(c) Then Exit For
With Worksheets("zaza").[b65536].End(xlUp)(2)
.Value = c
.Offset(0, -1) = Feuil1.Cells(lig, 1)
End With
End If
Next c
Next lig


End Sub

'lSteph

Sylvain P. a écrit :
Bonjour,

J'ai une feuille Excel avec des données disposer de la façon
suivante :
Entreprise1 Nom1 Nom2 Nom 3
Entreprise2 Nom1 Nom2
Entreprise2 Nom1 Nom2 Nom3 Nom4
...

J'aimerai transposer les colonnes avec les données Nom en lignes pour
obtenir un tableau de la sorte :
Entreprise1 Nom1
Entreprise1 Nom2
Entreprise1 Nom 3
Entreprise2 Nom1
Entreprise2 Nom2
Entreprise2 Nom 3
Entreprise2 Nom 4
...


J'ai écrit le code suivant. Mais ce n'est pas très performant.

Range("A1").Select
Dim LastCell 'Dernière cellule au croisement
Dim Plage1 ' Plage D1:Dernière cellule
Dim Plage2 ' Plage C1:Dernière cellule

Cells(Cells.Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row, Cells.Find("*",
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column).Select
Set LastCell = Selection
Range("E" & LastCell.Row).Select
Range(Selection, Cells(5)).Select
Set Plage1 = Selection

For Each c In Plage1
If c.Value <> 0 Then
Range("A" & c.Row).EntireRow.Select
Selection.Insert Shift:=xlDown
c.EntireRow.Copy
Range("A" & c.Row - 1).EntireRow.Select
ActiveSheet.Paste
Range("e" & c.Row - 1).Copy
Range("D" & c.Row).Select
ActiveSheet.Paste
Range("e" & c.Row - 1).ClearContents
Range("e" & c.Row).ClearContents

End If
Next


Auriez-vous des conseils, des idées ?
Merci par avance.

A+


Avatar
Sylvain P.
Merci beaucoup à tous les deux !
ça marche super bien !

Bon week-end !