repeter une partie de macro différemment (incrémentée)

tecroc84

XLDnaute Nouveau
Bonjour a toutes et tous .
j'aurais besoin de votre aide sur un problème de répétition dans la macro suivante:


Rows("362:362").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("291:291").Select
Selection.Copy
Rows("362:362").Select
ActiveSheet.Paste

Rows("458:458").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("387:387").Select
Selection.Copy
Rows("458:458").Select
ActiveSheet.Paste

comme vous pouvez le voir sur les partie 1 et 2 la différence se fait toutes les 96 lignes
je dois faire repeter celle ci 240 fois (jusqu'a la lignes 24000 environ )
ma question est la suivante : comment faire cette manip en une seule fois (si c'est possible)
je remercie d'avance toutes celles et ceux qui me viendront en aide.
Cordialement David.
 

job75

XLDnaute Barbatruc
Bonjour tecroc84, bienvenue sur XLD,

Puisque vous ne joignez pas de fichier (lisez la Charte du forum) juste quelques conseils.

Il suffit de faire une boucle du type For i = fin To 362 Step -n avec fin et n à remplacer par les nombres adéquats.

En effet puisqu'à chaque fois vous insérez une ligne il faut commencer par la fin.

Pour le copier-coller utilisez la méthode a.Copy b c'est plus rapide.

Et n'utilisez pas de Select, ils sont inutiles et ralentissent la macro.

A+
 

tecroc84

XLDnaute Nouveau
Merci beaucoup pour votre réponse rapide Job75 je n'est pas mis le reste de la macro car cela n'a rien a voir avec cette partie mais s'il la faut dorénavant je la joindrai.
je vais essayer ce que vous m'avez donné comme solution et je vous tiens au courant.
cordialement David
 

tecroc84

XLDnaute Nouveau
rebonjour ,
J'ai oublié de préciser que je débute en macro donc allez y doucement svp
j'ai rentré la ligne de commande suivante (For i=22420 To 3 Step -96 Next ) sans les parenthèses mais cela ne donne rien .
je joint mon fichier et vous explique ce que je voudrais :
la ligne 3 celle avec la date doit se répéter sur tous les versos
donc il faut que j’insère une ligne au dessus de la 74 (a sa place réellement)
malheureusement la troisième ligne change sur tous les rectos suivant donc je suis obligé de répéter
chaque troisième ligne sur chaque versos suivant
cette opération se répète donc toutes les 96 lignes pour la création des lignes et toutes les 71 lignes pour le copié collé pouvez vous me donner une ligne de commande pouvant exécuter cette opération rapidement
et non pas comme j'ai commencé a faire en répétant l’opération 240 fois
Merci d'avance .
Cordialement
 

Pièces jointes

  • FEUILLE ACT 29 AOUT AU 20 NOV1 2016.xlsx
    211 KB · Affichages: 36
  • FEUILLE ACT 29 AOUT AU 20 NOV1 2016.xlsx
    211 KB · Affichages: 28
  • FEUILLE ACT 29 AOUT AU 20 NOV1 2016.xlsx
    211 KB · Affichages: 34
Dernière édition:

job75

XLDnaute Barbatruc
Bonsoir,

Je rentre de soirée.

On se demande bien pourquoi il faut s'intéresser à la ligne 74 plutôt qu'à une autre mais bon...

A exécuter sur le fichier du post #4 :
Code:
Sub Insertion()
Dim i&
Application.ScreenUpdating = False  'pour accélérer
With Sheets("Feuil1")
  For i = 3304 To 74 Step -95
    .Rows(i).Insert
    .Rows(i - 71).Copy .Rows(i)
  Next
End With
End Sub
La macro ne doit servir qu'une seule fois.

Bonne nuit.
 

tecroc84

XLDnaute Nouveau
Bonjour,
J’espère que tu t'est bien amusé a ta soirée .
Ton code marche du tonnerre , et pour ça je te remercie infiniment.
Maintenant que cela fonctionne , je voudrais pas abuser mais j'ai besoin de reproduire
la mise en page de la page 1 (recto , verso ) sur toutes les autres pages (236 au total)
que ce soit l’entête le pied de page et l'encadrement . Mais ce n'est pas le plus important.
Merci beaucoup .

ps :comment mettre le sujet résolu ?
 

job75

XLDnaute Barbatruc
Bonjour tecroc84,

Puisque vous parlez de recto-verso c'est qu'il s'agit d'imprimer.

Alors pourquoi ne pas imprimer sur une seule page ???

Voyez ces 2 macros, pour imprimer activez les lignes des .PrintOut :
Code:
Sub Imprimer_Tout()
Dim i&
With Sheets("Feuil1")
  .PageSetup.FitToPagesWide = 1
  .PageSetup.FitToPagesTall = 1
  i = 1
  While .Cells(i, 1) <> ""
    .PageSetup.PrintArea = .Cells(i, 1).Resize(95, 14).Address '.Resize(88, 14) si l'on veut s'arrêter au Total
    .PrintPreview 'uniquement pour tester
    '.PrintOut 'pour imprimer
    i = i + 95
  Wend
End With
End Sub

Sub Imprimer_Partie()
Dim cherche$, c As Range, i&
With Sheets("Feuil1")
  Do
    cherche = InputBox("Nom (en partie ou totalité) ou n° du matricule :", "Recherche", cherche)
    If cherche = "" Then Exit Sub
    Set c = .[A:N].Find(cherche, , xlValues, xlPart)
    If Not c Is Nothing Then i = c.Row
  Loop While i Mod 95 <> 1
  .PageSetup.FitToPagesWide = 1
  .PageSetup.FitToPagesTall = 1
  .PageSetup.PrintArea = .Cells(i, 1).Resize(95, 14).Address '.Resize(88, 14) si l'on veut s'arrêter au Total
  .PrintPreview 'pour tester
  '.PrintOut 'pour imprimer
End With
End Sub
A+
 

tecroc84

XLDnaute Nouveau
rebonjour,
je suis désolé , j'ai testé la macro seule cela me met sur 2 page et je ne sais pas pourquoi
cela me fais buguer excel a chaque essai (obligé de tout fermer par le gestionnaire de taches)
J'ai utilisé la macro suivante qui fonctionne comme je suppose que vous vouliez afficher les pages
sauf que cela me donne toujours une pages vide entre chaque pages voulu.
Je pense que l'on doit pouvoir raccourcir et arranger tout ça mais étant novice je me sers beaucoup de l'enregistrement
pour créer des macros et la je sèche.
Cordialement.


Sub lmn()
'
' lmn Macro
'

Columns("K:M").Select
Range("M1").Activate
Selection.Delete Shift:=xlToLeft
'

' miseenpages1 Macro
'
ActiveSheet.PageSetup.CenterHeader = "&BCloture de cycle CR du 29 Aout au 20 Novembre 2016&B"
ActiveSheet.PageSetup.RightFooter = "&B&D&B"
ActiveSheet.PageSetup.CenterFooter = " "
ActiveSheet.PageSetup.LeftFooter = " "

'
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&BCloture de cycle CR du 29 Aout au 20 Novembre 2016&B"
.RightHeader = ""
.LeftFooter = " "
.CenterFooter = " "
.RightFooter = "&B&D&B"
.LeftMargin = Application.InchesToPoints(0.354330708661417)
.RightMargin = Application.InchesToPoints(0.15748031496063)
.TopMargin = Application.InchesToPoints(0.708661417322835)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0.15748031496063)
.FooterMargin = Application.InchesToPoints(0.275590551181102)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintSheetEnd
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlOverThenDown
.BlackAndWhite = False
.Zoom = 74

End With
Application.PrintCommunication = True


End Sub
 

job75

XLDnaute Barbatruc
Bonjour tecroc84,

Au temps pour moi !!!

Pour pouvoir imprimer ce qui concerne un salarié sur une seule page il faut préalablement mettre le Zoom d'impression à False :
Code:
Sub Imprimer_Tout()
Dim i&
With Sheets("Feuil1")
  .PageSetup.Zoom = False
  .PageSetup.FitToPagesWide = 1
  .PageSetup.FitToPagesTall = 1
  i = 1
  While .Cells(i, 1) <> ""
    .PageSetup.PrintArea = .Cells(i, 1).Resize(95, 14).Address '.Resize(88, 14) si l'on veut s'arrêter au Total
    .PrintPreview 'uniquement pour tester
    '.PrintOut 'pour imprimer
    i = i + 95
  Wend
End With
End Sub

Sub Imprimer_Partie()
Dim cherche$, c As Range, i&
With Sheets("Feuil1")
  Do
    cherche = InputBox("Nom (en partie ou totalité) ou n° du matricule :", "Recherche", cherche)
    If cherche = "" Then Exit Sub
    Set c = .[A:N].Find(cherche, , xlValues, xlPart)
    If Not c Is Nothing Then i = c.Row
  Loop While i Mod 95 <> 1
  .PageSetup.Zoom = False
  .PageSetup.FitToPagesWide = 1
  .PageSetup.FitToPagesTall = 1
  .PageSetup.PrintArea = .Cells(i, 1).Resize(95, 14).Address '.Resize(88, 14) si l'on veut s'arrêter au Total
  .PrintPreview 'pour tester
  '.PrintOut 'pour imprimer
End With
End Sub
Fichier joint.

A+
 

Pièces jointes

  • FEUILLE ACT 29 AOUT AU 20 NOV1 2016(1).xlsm
    229.3 KB · Affichages: 32

Discussions similaires

Statistiques des forums

Discussions
314 450
Messages
2 109 727
Membres
110 552
dernier inscrit
jasson