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

  • Initiateur de la discussion Initiateur de la discussion SELKAIM
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

SELKAIM

XLDnaute Nouveau
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
 
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)
VB:
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
 
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 :/

VB:
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
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
5
Affichages
235
Réponses
8
Affichages
233
Réponses
4
Affichages
177
Réponses
3
Affichages
193
Réponses
8
Affichages
466
Réponses
10
Affichages
281
  • Question Question
Microsoft 365 Erreur UBound
Réponses
4
Affichages
144
Réponses
2
Affichages
201
  • Question Question
Microsoft 365 worksheet_change
Réponses
29
Affichages
479
Réponses
2
Affichages
153
  • Question Question
Microsoft 365 Export données
Réponses
4
Affichages
649
Retour