Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

VBA reproduire une macro sur plusieurs lignes avec insertion de lignes

C

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
 

Pièces jointes

  • abo simple.xlsm
    15.3 KB · Affichages: 52
Trier par date Trier par votes

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+
 
Vote positif 0 Vote négatif

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 !
 

Pièces jointes

  • abo simple-1.xlsm
    38.9 KB · Affichages: 44
Vote positif 0 Vote négatif

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+
 
Vote positif 0 Vote négatif

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+
 
Vote positif 0 Vote négatif
C

CeDav

XLDnaute Nouveau

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
 
Vote positif 0 Vote négatif
C

CeDav

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif

JBARBE

XLDnaute Barbatruc
Bonjour à tous,

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

bonne journée !
 

Pièces jointes

  • abo simple-1.xlsm
    44.7 KB · Affichages: 46
Vote positif 0 Vote négatif
C

CeDav

XLDnaute Nouveau
JBARBE à dit:
Bonjour à tous,

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

bonne journée !
Cliquez pour agrandir...

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
 
Vote positif 0 Vote négatif
C

CeDav

XLDnaute Nouveau
JBARBE à dit:
Je ne comprends pas, dans votre exemple il y a bien 10 lignes supplémentaires copiées !
Cliquez pour agrandir...

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
 
Vote positif 0 Vote négatif

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+
 
Vote positif 0 Vote négatif
C

CeDav

XLDnaute Nouveau

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)
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

G
  • Question
XL 2019 Sélectionner un fichier pour mettre à jour une base de données
Réponses
3
Affichages
173
sylvanu
  • Question
Autres fenêtre "Publication"
Réponses
10
Affichages
427
ph.vanne
  • Résolu(e)
XL 2021 Exécuter une macro sur plusieurs feuilles
Réponses
9
Affichages
304
micie1509
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
530
robpellan52
R
G
  • Résolu(e)
Copie de données d'une feuille à une autre
Réponses
2
Affichages
529
gui22
G
Y
  • Question
Microsoft 365 Insérer des lignes selon variable
Réponses
1
Affichages
423
gbinforme
G
F
  • Résolu(e)
XL 2021 Réaliser une macro pour copier une ligne avec formule ?
Réponses
4
Affichages
555
fanou06
F
B
  • Question
Microsoft 365 reproduire la mise en forme d'un tableau avec VBA
Réponses
11
Affichages
1 K
BER6543
B
F
  • Résolu(e)
XL 2021 Créer Macro permettant d'indexer des nouveaux clients ? [Résolu]
4 5 6
Réponses
82
Affichages
3 K
fanou06
F
  • Résolu(e)
Microsoft 365 Macro fonctionnant avec excel 365 sur windows 11 mais ne fonctionnent pas sur un autre windows 11 avec aussi un excel 365
Réponses
11
Affichages
859
mouchtre
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…