VBA reproduire une macro sur plusieurs lignes avec insertion de lignes

CeDav

XLDnaute Nouveau
Bonjour à tous,
1er post sur le forum !

Bon j'essaie depuis 2 jours ceci :
J'ai un tableau avec 5 lignes de A à K
Je souhaite faire une succession d'action à partir de la ligne 1 (notamment inserer valeur = H1 lignes, puis copier la ligne sur toutes les lignes insérées, puis copier une colonne dans une autre).
Jusque là, j'y arrive avec ma macro ci dessous.
Une cette macro effectuée, je souhaite recommencer sur la ligne qui était au départ la ligne suivante, c'est à dire la ligne 2, puis refaire jusqu'à la dernière ligne.
C'est la que je bloque

ma macro :
Sub InsertionAbo1()
Range("A1").Select
ActiveCell.EntireRow.Resize(rowsize:=Range("H1")).Insert Shift:=xlDown
Rows("11:11").Select
Selection.Copy
Rows("1:10").Select
ActiveSheet.Paste
Range("K1:K11").Select
Selection.Copy
Range("I1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Feuil2").Select
Range("A1:A11").Select
Selection.Copy
Sheets("Feuil1").Select
Range("K1").Select
ActiveSheet.Paste
Range("A2").Select
ActiveCell.FormulaR1C1 = "=IF(R[-1]C<52,R[-1]C+1,1)"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A11"), Type:=xlFillDefault
Range("A2:A11").Select
End Sub

Je vous mets le fichiers en pj
Merci d'avance de votre aide
 

Fichiers joints

Paf

XLDnaute Barbatruc
Bonjour CeDav,

Dans les cas d'ajout ou de suppressions de lignes, il vaut mieux commencer par la fin.

Au départ on a 5 lignes. Si on veut rajouter X lignes après chaque ligne, en commençant par le début, on prend la ligne 1 , on rajoute 2 lignes ; la ligne qui était initialement en 2 se retrouve désormais en 4....

si on commence par la fin, on prend la ligne 5, on rajoute des lignes, on passe à la ligne 4 qui n'a pas changé de place ...
ce qui permet d'utiliser des boucles.

un essai :

Code:
Sub InsertionAbo1()
With Worksheets("Feuil1") ' à adapter
  For i = 5 To 1 Step -1
    .Rows(i).Copy
    .Rows(i + 1).Resize(rowsize:=.Cells(i, 8)).Insert Shift:=xlDown
  Next
  .Range("A1").AutoFill Destination:=.Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row), Type:=xlFillSeries
End With
End Sub
A+
 

JBARBE

XLDnaute Barbatruc
Bonsoir à tous,

Peut-être ceci :

Code:
Sub Insertion()
Dim i As Long
Application.ScreenUpdating = False
For i = 1 To 65536 Step 11
With Sheets("Feuil1")
If .Cells(i, 1) = "" Then Exit Sub
.Cells(i, 1).EntireRow.Resize(rowsize:=Cells(1, 8)).Insert Shift:=xlDown
.Range(Cells(i + 10, 1), Cells(i + 10, 256)).Copy
.Range(Cells(i, 1), Cells(i + 9, 256)).Select
ActiveSheet.Paste
Sheets("Feuil1").Select
.Range(Cells(i, 11), Cells(i + 10, 11)).Copy
.Cells(i, 9).Select
ActiveSheet.Paste
Sheets("Feuil2").Select
Range("A1:A11").Copy
Sheets("Feuil1").Select
.Cells(i, 11).Select
ActiveSheet.Paste
.Cells(i + 1, 1).FormulaR1C1 = "=IF(R[-1]C<52,R[-1]C+1,1)"
.Cells(i + 1, 1).AutoFill Destination:=Range(Cells(i + 1, 1), Cells(i + 10, 1)), Type:=xlFillDefault
End With
Next i
Application.ScreenUpdating = True
End Sub
bonne nuit !
 

Fichiers joints

Paf

XLDnaute Barbatruc
re bonjour à tous,

une nouvelle version qui prend en compte le retour de N° à 1 après 52 que j'avais 'zappé'.
Par contre pas compris (et donc pas ajouter) le fait de copier 1/11 en colonne I; si ça marche pour la ligne 1 qui doit être copiée 10 fois (valeur de H1) donc 11 lignes au total, que faire pour la ligne 2 qui doit être copiée 6 fois (H2):
on copie en incrémentant de 1/11 à 7 /11 ou bien 1/7 à 7/7 ??

Code:
Sub Insertion_V2()
With Worksheets("Feuil1") ' à adapter
  For i = 5 To 1 Step -1
    .Rows(i).Copy
    .Rows(i + 1).Resize(rowsize:=.Cells(i, 8)).Insert Shift:=xlDown
  Next
    .Range("A2").Formula = "=IF(A1<52,A1+1,1)"
    .Range("A2").AutoFill Destination:=.Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row), Type:=xlFillDefault
End With
End Sub
A+
 

Paf

XLDnaute Barbatruc
Re,

c'est gentil d'aimer mon post 4,mais j'aurais préféré savoir ce qu'il fallait faire pour la colonne I !

Une autre version qui prend en compte la colonne I:
Code:
Sub Insertion_V3()
With Worksheets("Feuil1") ' à adapter
  For i = 5 To 1 Step -1
    .Rows(i).Copy
    .Rows(i + 1).Resize(rowsize:=.Cells(i, 8)).Insert Shift:=xlDown
    For j = 1 To .Cells(i, 8) + 1
        .Cells(i + j - 1, 9).NumberFormat = "@"
        .Cells(i + j - 1, 9) = CStr(j & "/" & .Cells(i, 8) + 1)
    Next
  Next
    .Range("A2").Formula = "=IF(A1<52,A1+1,1)"
    .Range("A2").AutoFill Destination:=.Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row), Type:=xlFillDefault
End With
End Sub
A+
 

CeDav

XLDnaute Nouveau
re bonjour à tous,

une nouvelle version qui prend en compte le retour de N° à 1 après 52 que j'avais 'zappé'.
Par contre pas compris (et donc pas ajouter) le fait de copier 1/11 en colonne I; si ça marche pour la ligne 1 qui doit être copiée 10 fois (valeur de H1) donc 11 lignes au total, que faire pour la ligne 2 qui doit être copiée 6 fois (H2):
on copie en incrémentant de 1/11 à 7 /11 ou bien 1/7 à 7/7 ??

Code:
Sub Insertion_V2()
With Worksheets("Feuil1") ' à adapter
  For i = 5 To 1 Step -1
    .Rows(i).Copy
    .Rows(i + 1).Resize(rowsize:=.Cells(i, 8)).Insert Shift:=xlDown
  Next
    .Range("A2").Formula = "=IF(A1<52,A1+1,1)"
    .Range("A2").AutoFill Destination:=.Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row), Type:=xlFillDefault
End With
End Sub
A+
Merci beaucoup Paf ! (j'ai bien compris l'idée de partir de la fin, c'est évident quand tu le dis !!)
J'ai effectivement mal présenté les choses pour le 1/x : en fait il faut que ça aille de 1/(Hi+1) à (Hi+1)/(Hi+1)
Un exemple : pour la ligne 2 qui doit être copié 6 fois (H2), on copie en incrémentant de 1/7 à 7/7.

Autre chose, en colonne (A), la numération va en ajoutant +1 à chaque ligne entre (Ai) et (A(Hi+1)).
Un exemple : pour la ligne 2 qui doit être copié 6 fois (H2), si A2=48, alors A3=49, A4=50, A5=51, A6=52, A7=1, A8=2

Merci d'avance
 

CeDav

XLDnaute Nouveau
Re,

c'est gentil d'aimer mon post 4,mais j'aurais préféré savoir ce qu'il fallait faire pour la colonne I !

Une autre version qui prend en compte la colonne I:
Code:
Sub Insertion_V3()
With Worksheets("Feuil1") ' à adapter
  For i = 5 To 1 Step -1
    .Rows(i).Copy
    .Rows(i + 1).Resize(rowsize:=.Cells(i, 8)).Insert Shift:=xlDown
    For j = 1 To .Cells(i, 8) + 1
        .Cells(i + j - 1, 9).NumberFormat = "@"
        .Cells(i + j - 1, 9) = CStr(j & "/" & .Cells(i, 8) + 1)
    Next
  Next
    .Range("A2").Formula = "=IF(A1<52,A1+1,1)"
    .Range("A2").AutoFill Destination:=.Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row), Type:=xlFillDefault
End With
End Sub
A+
Désolé je suis un peu lent j'ai aimé avant de commencer à répondre !
Merci pour ton code modifié, ton intuitation était bonne, c'est tout à fait ça.

Reste simplement la numérotation en colonne (A), la numération va en ajoutant +1 à chaque ligne entre (Ai) et (A(Hi+1)).
Un exemple : pour la ligne 2 qui doit être copié 6 fois (H2), si A2=48, alors A3=49, A4=50, A5=51, A6=52, A7=1, A8=2
 

JBARBE

XLDnaute Barbatruc
Reste simplement la numérotation en colonne (A), la numération va en ajoutant +1 à chaque ligne entre (Ai) et (A(Hi+1)).
Un exemple : pour la ligne 2 qui doit être copié 6 fois (H2), si A2=48, alors A3=49, A4=50, A5=51, A6=52, A7=1, A8=2
Bonjour à tous,

Peut-être ceci dont j'ai modifié ma macro Insertion !

bonne journée !
 

Fichiers joints

CeDav

XLDnaute Nouveau
Bonjour à tous,

Peut-être ceci dont j'ai modifié ma macro Insertion !

bonne journée !
Bonjour !
Merci pour votre code du premier post qui marche nickel, sauf qu'il insère toujours 10 lignes c'est à dire toujours la valeur H1, alors qu'il faut insérer pour chaque ligne i, la valeur (Hi). Par exemple : pour la ligne 2 (au début), il faut insérer la valeur (H2).
La macro modifié que vous venez de me renvoyer bloque cf pj.
Merci encore de votre aide
imp ecran macro bloque.jpg
 

CeDav

XLDnaute Nouveau
Je ne comprends pas, dans votre exemple il y a bien 10 lignes supplémentaires copiées !
Oui, parce que la case H1 = 10 !
et pour ligne suivante (ligne 2 au départ, devenue ligne 12), le nombre de ligne à insérer est de 6 (=H2 du départ, devenue H12)

Par ailleurs, comme je l'ai signalé à Pas, j'ai aussi mal présenté les choses pour le 1/x : en fait il faut que ça aille de 1/(Hi+1) à (Hi+1)/(Hi+1)
Un exemple : pour la ligne 2 qui doit être copié 6 fois (H2), on copie en incrémentant de 1/7 à 7/7.

Merci
 

Paf

XLDnaute Barbatruc
Re,

La dernière version (?),Pour chaque ligne initiale, les ligne ajoutée sont incrémentées par rapport au N° initial, sans pouvoir dépasser 52.

Code:
Sub Insertion_V4()
With Worksheets("Feuil1") ' à adapter
  For i = 5 To 1 Step -1
    Application.CutCopyMode = False
    .Rows(i).Copy
    .Rows(i + 1).Resize(rowsize:=.Cells(i, 8)).Insert Shift:=xlDown
    For j = 1 To .Cells(i, 8) + 1
        .Cells(i + j - 1, 9).NumberFormat = "@"
        .Cells(i + j - 1, 9) = CStr(j & "/" & .Cells(i, 8) + 1)
        If j < .Cells(i, 8) + 1 Then .Cells(i + j, 1).FormulaR1C1 = "=IF(R[-1]C<52,R[-1]C+1,1)"
    Next
  Next
End With
End Sub
A+
 

CeDav

XLDnaute Nouveau
Re,

La dernière version (?),Pour chaque ligne initiale, les ligne ajoutée sont incrémentées par rapport au N° initial, sans pouvoir dépasser 52.

Code:
Sub Insertion_V4()
With Worksheets("Feuil1") ' à adapter
  For i = 5 To 1 Step -1
    Application.CutCopyMode = False
    .Rows(i).Copy
    .Rows(i + 1).Resize(rowsize:=.Cells(i, 8)).Insert Shift:=xlDown
    For j = 1 To .Cells(i, 8) + 1
        .Cells(i + j - 1, 9).NumberFormat = "@"
        .Cells(i + j - 1, 9) = CStr(j & "/" & .Cells(i, 8) + 1)
        If j < .Cells(i, 8) + 1 Then .Cells(i + j, 1).FormulaR1C1 = "=IF(R[-1]C<52,R[-1]C+1,1)"
    Next
  Next
End With
End Sub
A+
Magnifique !
Enorme merci j'étais arrivé à faire le +1 mais pas à le limiter avec le 52 avec ce code :
Sub Insertion_V5()
With Worksheets("Feuil1") ' à adapter
For i = 5 To 1 Step -1
.Rows(i).Copy
.Rows(i + 1).Resize(rowsize:=.Cells(i, 8)).Insert Shift:=xlDown
For j = 1 To .Cells(i, 8) + 1
.Cells(i + j - 1, 9).NumberFormat = "@"
.Cells(i + j - 1, 9) = CStr(j & "/" & .Cells(i, 8) + 1)
Next
For k = 1 To .Cells(i, 8)
.Cells(i + k, 1) = .Cells(i + k - 1, 1) + 1
Next
Next
End With
End Sub

Mais je me rends compte que je commençais par créer une nouvelle variable alors que je n'en avais pas besoin !
Ton code est élégant et simple, superbe. Et j'ai appris beaucoup. Surtout qu'avec ces codes, c'est comme dans la vie il faut oser ! (et apprendre la langue bien sûr)
 

Discussions similaires


Haut Bas