Discussion :

[magot98]

Bonjour,

Je cherche à réarranger des lignes excel en fonction des critères suivants:
-Si la ligne contient des valeurs au-delà de la colonne B (donc depuis C et suivantes), je souhaite couper ces valeurs, et insérer une ligne supplémentaire en dessous pour chaque valeur surnuméraire
-Pour chaque ligne, je souhaite garder la valeur de base qui se trouve dans la cellule A

C'est plus facile d'expliquer en image:



Merci pour votre aide!

[BENNASR]

Bonsoir magot98, la forum
Je pars de la principe suivante :
* Que tes données figurent en feuil 1
* Que tu cherche à envoyer les données en feuil 2
Voila le code bricolé (sachant que moi aussi débutant Autodidacte)
Bonne continuation

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub transposer()
Dim dercol As Long
Dim i As Long
Dim b As Long
' Commence par netoyer la feuille destination
With Sheets("feuil2")
.Select
.Cells.Select
Selection.ClearContents
End With
Application.ScreenUpdating = False
With Sheets("feuil1")
dercol = .Cells(1, Cells.Columns.Count).End(xlToLeft).Column
i = .Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To i
For j = 1 To dercol
If .Cells(i, j + 1) <> "" Then
b = Sheets("feuil2").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("feuil2").Range("A" & b).Value = .Cells(i, 1).Value
Sheets("feuil2").Range("B" & b).Value = .Cells(i, j + 1).Value
End If
Next j
Next i
End With
Application.ScreenUpdating = True
End Sub

************************
Vis comme si tu devais mourir demain.
Apprends comme si tu devais vivre toujours.
Mahatma Gandhi

[magot98]

Bonjour Bennasr,

On y est presque, merci... mais pas tout à fait. En effet, lorsque je lance la macro pour le fichier en annexe, il manque des lignes pour la ligne 11.Classeur_3.xlsm

[BENNASR]

oui y a une erreur
essayer ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub transposer()
Dim dercol As Long
Dim i As Long
Dim b As Long
' Commence par netoyer la feuille destination
With Sheets("feuil2")
.Select
.Cells.Select
Selection.ClearContents
End With
Application.ScreenUpdating = False
With Sheets("feuil1")
i = .Range("A" & Rows.Count).End(xlUp).Row
dercol = .Cells(i, Cells.Columns.Count).End(xlToLeft).Column
 
For i = 1 To i
For j = 1 To dercol
If .Cells(i, j + 1) <> "" Then
b = Sheets("feuil2").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("feuil2").Range("A" & b).Value = .Cells(i, 1).Value
Sheets("feuil2").Range("B" & b).Value = .Cells(i, j + 1).Value
End If
Next j
Next i
End With
Application.ScreenUpdating = True
End Sub

[magot98]

Merci une fois encore Bennasr. Cela fonctionne pour le fichier Excel que j'ai inclus plus haut. Par contre cela ne fonctionne pas pour celui-ci: Worsheet_4.xlsm

[BENNASR]

C'est toujours comme ça le travail des bricoleurs