Transposer des colonnes en lignes

Le
Sylvain P.
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+
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
FFO
Le #19181391
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 !!!!!
michdenis
Le #19181381
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." 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+
gmlsteph
Le #19181581
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+


Sylvain P.
Le #19181891
Merci beaucoup à tous les deux !
ça marche super bien !

Bon week-end !
Publicité
Poster une réponse
Anonyme