Duplication de ligne en fonction de cellules

Bonjour à tous,

Je travaille sur un fichier Excel (en pièce jointe).

En fonction de la valeur se trouvant dans chaque cellule de la colonne A ( 2, 3,...), je souhaite dupliquer la ligne correspondante une fois, deux fois,...

Voici le code que j'ai écrit (donc loin d'être parfait):

Dim Plage As Range, Test As Long
Dim DerniereLigne As Long, Ligne As Long, n As Long

'Application.ScreenUpdating = False

DerniereLigne = Cells(65536, 1).End(xlUp).Row

Set Plage = Range(Cells(1, 1), Cells(DerniereLigne, 1))

For Each Occurence In Plage
    If Occurence > 1 Then

          n = Occurence - 1
          Cells(Occurence.Row + 1, 1).Resize(n, 1).EntireRow.Insert Shift:=xlDow

    End If
Next Occurence

End Sub

Ce que j'arrive à faire:

- En fonction du nombre en A, je peux créer une ou ou plusieurs nouvelles lignes

Ce que je n'arrive pas à faire:

- Copier les informations de la ligne précédente dans la ou les lignes nouvellement créées.

Enfin, en faisant un test sur un grand nombre de lignes, je me suis rendu compte que l'exécution de mon code était très long, n'y a-t-il pas moyen de l'accélérer?

En vous remerciant par avance pour votre aide

Bien cordialement

Singertwit

Bonsoir,

Par exemple ainsi :

Sub Bouton2_Cliquer()
Dim I As Long, NbLig As Long
Application.ScreenUpdating = False
For I = Cells(Rows.Count, 1).End(xlUp).Row To 4 Step -1
    NbLig = Cells(I, 1).Value - 1
    If NbLig > 0 Then
        Rows(I).Copy
        Rows(I).Resize(NbLig).Insert xlDown
    End If
Next I
Application.CutCopyMode = False
End Sub

Bonne soirée

Bonsoir,

Merci beaucoup pour ta réponse rapide.

Cela fonctionne bien mais sur un grand nombre de lignes (mon fichier fait plus de 3000 lignes), la macro met beaucoup de temps à s'exécuter.

Aurais-tu une solution pour accélérer l'exécution?

Merci encore pour ton aide

Bonne soirée

Singertwist

Re-,

Juste une info

Est-ce que tes lignes contiennent des formules, ou uniquement des valeurs?

@ te relire

Il ne s'agit que de valeurs.

Il n'y a aucune formule à reproduire. Mon fichier fait environ 3500 lignes.

Merci de ton aide

Bonne soirée

Singertwist

Bonsoir,

ne serait-ce pas les inserts qui ralentissent le code ?

En créant un nouveau tableau sur une autre feuille puis un copier coller sur la feuille d'origine ne serait-ce pas plus rapide ?

Ou bien en créant un tableau "VBA" qu'il suffirait de "coller" sur la feuille, comme cela tout serait en mémoire donc plus rapide, non ?

@ bientôt

LouReeD

Re-,

Via un tableau VBA

Avec 2317 lignes, donnant un total de 6819 lignes en tout, avec mon précédent code, je mettais un peu plus de 14 secondes...

Avec celui-ci, 0.07 seconde, pour le même résultat

Je recopie le tableau à partir de la celllule H4 (à adapter, en fonction du nombre de colonnes dans ton tableau initial)

Le code :

Option Base 1

Sub Bouton2_Cliquer()
Dim Tbl
Dim Tbl2()
Dim NbCol As Long
Dim I As Long, C As Long
Dim J As Byte, K As Byte
Dim T
T = Timer
Tbl = Range("A4:D" & Cells(Rows.Count, 1).End(xlUp).Row)
NbCol = Application.Sum(Columns(1))
ReDim Preserve Tbl2(NbCol, 4)
C = 1
For I = LBound(Tbl) To UBound(Tbl)
    For J = 1 To Tbl(I, 1)
        For K = 1 To 4
            Tbl2(C, K) = Tbl(I, K)
        Next K
        C = C + 1
    Next J
Next I
Range("H4").Resize(NbCol, 4) = Tbl2
MsgBox Timer - T
End Sub

PS : N'oublie pas l'option base 1, tout en haut du module....

Bonne nuit

Bonjour,

Tout d'abord merci à tous pour vos réponses et votre aide.

J'ai un peu adapté ton code à mes besoins car le tableau que je vais utiliser plus tard comporte bien plus de lignes et de colonnes.

Cependant, dans le cas où j'ai 0, j'aurai aimé que la ligne soit conservé (comme dans le cas où j'ai 1).

Aurais-tu une idée pour ne pas supprimer les ligner ayant 0? J'ai cherché, mais je dois t'avouer que j'ai un peu de mal à comprendre toutes les lignes de ton code

Voici le code que j'ai adapté:

Option Base 1
Sub rl_Bouton2_Cliquer()

Dim Tbl
Dim Tbl2()
Dim NbCol As Long
Dim I As Long, C As Long
Dim J As Byte, K As Byte
Dim T
T = Timer
Tbl = Range("A1:O" & Cells(Rows.Count, 1).End(xlUp).Row)
NbCol = Application.Sum(Columns(1))
ReDim Preserve Tbl2(NbCol, 15)
C = 1
For I = LBound(Tbl) To UBound(Tbl)
    For J = 1 To Tbl(I, 1)
        For K = 1 To 15
            Tbl2(C, K) = Tbl(I, K)
        Next K
        C = C + 1
    Next J
Next I
Sheets("Feuil1").Range("A4").Resize(NbCol, 15) = Tbl2

En te remerciant pour ton aide

SIngertwist

Bonjour,

Essaie ainsi :

Sub rl_Bouton2_Cliquer()
Dim Tbl
Dim Tbl2()
Dim NbCol As Long
Dim I As Long, C As Long
Dim J As Byte, K As Byte
Dim T
T = Timer 'c'est juste pour chronométrer le temps que mettra le code à tout faire...
Tbl = Range("A1:O" & Cells(Rows.Count, 1).End(xlUp).Row)
NbCol = Application.Sum(Columns(1)) + Application.CountIf(Columns(1), 0)
    'je totalise les nombres en colonne 1, et je rajoute le nombre de cellules ayant 0
ReDim Preserve Tbl2(NbCol, 15)
C = 1
For I = LBound(Tbl) To UBound(Tbl)
    For J = 1 To Application.Max(1, Tbl(I, 1)) 'ici, même si on a 0, on copie quand même la ligne
                                               'dans le Tbl2
        For K = 1 To 15
            Tbl2(C, K) = Tbl(I, K)
        Next K
        C = C + 1
    Next J
Next I
Sheets("Feuil1").Range("A4").Resize(NbCol, 15) = Tbl2
MsgBox Timer - T
End Sub

Bonne soirée

Super, merci beaucoup de ta réactivité et de ton aide, cela fonction parfaitement.

Merci encore, tu viens de m'enlever une sacrée épine du pied.

Singertwist.