Microsoft 365 Dupliquer lignes en fonction du nombre de données entre "/" dans une cellule

[de_hanstrapp]

Bonsoir le forum,

J'ai dans la colonne F de mon tableau plusieurs données qui sont séparées par un "/".
Je voudrais dupliquer le contenu des colonnes A, B, C, D et E autant de fois qu'il y a de données entre le "/" comme dans l'exemple joint.

Quelqu'un aurait t il une idée pour m'éviter de de nombreux copier/coller avec un risque évident de suppression de données...

Merci par avance pour votre aide.

NSAPG

 

[Staple1600]

Bonsoir

Une idée à peaufiner

Sub test()
Dim dl&, t, rng As Range
For dl = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
t = Split(Cells(dl, "F"), "/")
Set rng = Cells(dl, "A").Resize(, 5)
x = UBound(t) - 1
Rows(dl).Resize(x).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(dl, "F").Resize(x + 1) = Application.Transpose(t)
Cells(dl, "A").Resize(x + 1, 5).Value = rng.Value
Next
End Sub

 

[de_hanstrapp]

Bonsoir Staple,
Merci pour ce code.
Il fonctionne quasi parfaitement si ce n'est qu'il me supprime à chaque fois la dernière donnée.
Dans mon fichier exemple je devrais avoir 6 lignes pour la premier série de données et pour la seconde alors qu'en exécutant la macro mon résultat et de 5 et 4 lignes.
Par ailleurs y a t il une possibilité de supprimer les espaces ?
NSAPG

 

[Staple1600]

Re

C'est pour cela que je parlais de peaufiner

Sub test_II()
Dim dl&, t, rng As Range
For dl = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
t = Split(Cells(dl, "F"), "/")
Set rng = Cells(dl, "A").Resize(, 5)
x = UBound(t)
Rows(dl).Resize(x).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(dl, "F").Resize(x + 1) = Application.Transpose(t)
Cells(dl, "A").Resize(x + 1, 5).Value = rng.Value
Next
End Sub

Je repasse plus tard pour la suite

 

[Staple1600]

Re

Est-ce le résultat escompté avec cette version?

Sub test_III()
Dim dl&, t, rng As Range
Application.ScreenUpdating = False
For dl = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
t = Split(Cells(dl, "F"), "/")
Set rng = Cells(dl, "A").Resize(, 5)
x = UBound(t)
Rows(dl).Resize(x).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(dl, "F").Resize(x + 1) = Application.Transpose(t)
Cells(dl, "F").Resize(x + 1) = Application.Trim(Cells(dl, "F").Resize(x + 1))
Cells(dl, "F").Columns.AutoFit
Cells(dl, "A").Resize(x + 1, 5).Value = rng.Value
Next
nettoyage
End Sub
Sub nettoyage()
Columns("F:F").Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
Columns("F:F").Replace What:=Chr(13), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
Columns("F:F").Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
Cells.RowHeight = 15
End Sub

 

[Amilo]

Bonsoir nsapg, Staple1600,
Une autre proposition avec Power Query avec une démo en vidéo ici

Cordialement

 

[Staple1600]

Bonsoir Amilo

Hop dans ma PouQuette.
Merci.

=>nasapg
C'est quand tu veux pour ton feedback sur la macro test_III

 

[de_hanstrapp]

Re

Est-ce le résultat escompté avec cette version?

Sub test_III()
Dim dl&, t, rng As Range
Application.ScreenUpdating = False
For dl = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
t = Split(Cells(dl, "F"), "/")
Set rng = Cells(dl, "A").Resize(, 5)
x = UBound(t)
Rows(dl).Resize(x).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(dl, "F").Resize(x + 1) = Application.Transpose(t)
Cells(dl, "F").Resize(x + 1) = Application.Trim(Cells(dl, "F").Resize(x + 1))
Cells(dl, "F").Columns.AutoFit
Cells(dl, "A").Resize(x + 1, 5).Value = rng.Value
Next
nettoyage
End Sub
Sub nettoyage()
Columns("F:F").Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
Columns("F:F").Replace What:=Chr(13), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
Columns("F:F").Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
Cells.RowHeight = 15
End Sub

J'ai ce message d'erreur quand je suis sur mon fichier (et non sur l'exemple).
Rows(dl).Resize(x).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

 

[de_hanstrapp]

Bonsoir nsapg, Staple1600,
Une autre proposition avec Power Query avec une démo en vidéo ici

Cordialement

Merci Amilo, cela correspond parfaitement à ce que je souhaitais faire !
NSAPG

 

[Staple1600]

Re

La macro a été conçue en se basant sur l'exemple
Elle fonctionne donc sur l'exemple.
Rien de plus logique en somme.


Donc tu sais ce qu'il te reste à faire.