Microsoft 365 Dupliquer une ligne selon une valeur X (macro)

[SELKAIM]

Bonjour,

Tout d'abord je n'ai aucune formation VBA, je suis à mes débuts et ce n'est pas mon cœur de métier mais j'ai besoin de réussir une macro afin de gagner du temps au boulot.

J'ai un fichier excel, construit de la sorte :

A B C D
1 MAX 16 ADRESSE 2


J'aimerais que cette ligne (A1;D1) soit dupliqué 1 fois (D-1) (Si D=5, alors dupliqué 4 fois^^)
J'aurais quotidiennement environ 50 lignes, et 10% d'entres elles auront un nombre ">2" en colonne "D", donc pas mal de duplication de ligne.

J'ai trouvé pas mal de code faisant cela, mais impossible d'en faire fonctionner un.
J'ai trouvé celui-ci, j'ai essayé de l'adapter mais ca ne marche pas.

Voici mon code :

AA est égale à D (dans mon exemple soit le nbr de ligne souhaité)
Z correspond à une colonne vierge permettant de stocker le "D-1"
A correspond à la colonne "NOM" afin de ne pas dupliquer 2 fois une ligne déjà dupliqué
3 correspond au numéro de ma première ligne de données.

<code basic>
Sub duplique()
Application.ScreenUpdating = False
der = Range("A65536").End(xlUp).Row + 1
For n = 3 To Range("A65536").End(xlUp).Row
For i = 3 To der
If Range("Z" & i) > 1 Then
eti = Range("A" & i).Value
nbr = Range("Z" & i).Value
Range("AA" & i) = 1
For j = i + 1 To i + nbr - 1
If Range("A" & j).Value = eti Then
Range("AA" & j) = Range("AA" & j - 1) + 1
Range("Z" & j) = nbr
Else
Rows(j).Insert shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
Range("A" & j) = eti
Range("AA" & j) = Range("AA" & j - 1) + 1
Range("Z" & j) = Range("Z" & i).Value
der = der + 1
End If
Next j
i = j - 1
End If
Next i
Next n
End Sub
</code>

Merci de votre aide, à votre écoute,

Simon

 

[vgendron]

Hello
un essai avec le fichier suivant:
va voir le code, j'y ai mis des commentaires

 

[Staple1600]

Bonsoir le fil

NB: Merci vgendron pour le fichier exemple
Je me suis basé sur lui pour tester
Une autre façon de faire
(à réserver pour les cas où il n'y a pas trop de lignes à dupliquer)

Sub Dupliquer_Bis()
Dim i&
Application.ScreenUpdating = 0
On Error Resume Next
    For i = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        With Rows(i)
        .Copy: .Offset(1, 0).Resize(Cells(i, 5) - 1, 1).EntireRow.Insert
        End With
    Next i
Application.CutCopyMode = 0
End Sub

 

[SELKAIM]

Bonjour à tous, merci pour votre aide..
C'est super, j'ai réussi grace à vous.
PS : Les 2 codes marchent !
Merci Vgendron pour les commentaires qui m'ont permis de bien comprendre la démarche,

Portez vous bien,

Amicalement

Simon

 

[SELKAIM]

Je relance ce sujet, car j'ai une nouvelle problématique.
Je souhaiterais incrémenter un colonne suite à la duplication. (ici la colonne I) (ex : 16400A, 16400B dans l'idéal) si il y a des doublons suite à la duplication. J'espère que je suis clair ?

Voilà mon code actuel :
La colonne A est celle de du nbr de lignes à insérer.
La colonne B est celle des noms des n° de dossier pour identifier les doublons
La colonne I correspond au numéro du colis à incrémenter par A,B, C etc..
Mais cela ne marche pas :/

Sub duplique()
Dim lig As Long, dup As Integer, dec As Integer, pos As Integer, cel
For lig = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
    dup = Cells(lig, "A").Value
    If dup > 1 Then
        Rows(lig + 1).Resize(dup - 1).Insert
        Rows(lig).Resize(dup).FillDown
        cel = Cells(lig, "I").Value
        pos = InStr(cel, " ")
        For dec = 1 To dup - 1
            Cells(lig + dec, "I").Value = Left(cel, pos - 1) & Chr(64 + dec) & Mid(cel, pos)
        Next dec
    End If
Next lig
End Sub