repeter macro avec décalage

passiflore

XLDnaute Nouveau
Bonjour,
Je débute en VBA, et j’ai besoin de votre aide.
Je vais essayer de trouver les mots....

J'ai une macro qui se répète 30 fois, mais il faudrait maintenant qu'elle se répète 90 fois. Mon code fait déjà 102 pages en fichier Word !!!

En fait, j'ai un document Excel avec 3 feuilles.
- La feuille 1 est un tableau a remplir tous les jours
- la feuille 2 est un tableau dans lequel doit se reporter certaines cellules de la feuille 1 dans les colonnes Jour 1 à Jour 90 en fonction du jour inscrit sur la feuille 1 (C4). Si (J) = 1, on remplira les colonnes JOUR 1 de la feuille B, si (J) = 2, les colonnes JOUR 2, etc.…
- la feuille 3 se met à jour par la même macro, mais reprend des cellules de la feuille 2.

En gros en fonction de la valeur de C4, il faut copier/coller dans une cellule différente mais sur la même ligne : B8 si la valeur de C4 est 1, F8 si la valeur de C4 est 2, etc. On décale de 4 colonnes à chaque fois.

Les Ranges avec un point devant ne changent jamais.
Seul les Ranges sans point devant varient en fonction de la valeur de C4.
Ce sont eux que je devrais décaler de 4 colonnes à chaque fois.
Peut-on demander d’exécuter la même macro en décalant toutes le range sans point devant de 4 colonnes à chaque fois ?

Merci par avance pour votre aide.
Céline

Voici une partie de mon code:

Sub SAM1()

Dim Lig_S As Long
Dim Lig_D As Long
Dim F_S As Worksheet
Dim F_D As Worksheet
Set F_S = Sheets("F1")
Set F_D = Sheets("F2")
Lig_D = F_D.Range("A65536").End(xlUp).Row + 1

For Lig_S = 44 To 3 Step -1
With F_S

If F_S.Range("C4").Value = 1 Then
F_D.Select
Application.CutCopyMode = False

.Range("C40,E40,G40,I40").Copy
Range("A1000").Select
ActiveSheet.Paste Link:=True
Selection.Copy
Range("B8").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range("A1000").EntireRow.Delete

.Range(" D40,F40,H40,J40").Copy
Range("A1000").Select
ActiveSheet.Paste Link:=True
Selection.Copy
Range("C8").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range("A1000").EntireRow.Delete

Range("C14").Value = .Range("M40").Value
Range("B47:C51").Value = .Range("C20:D24").Value
Range("B54:C55").Value = .Range("T21:U22").Value
Range("C38:C40").Value = .Range("E28:E30").Value
Range("C42:C44").Value = .Range("E31:E33").Value
Range("C25").Value = .Range("N16").Value
Range("C26").Value = .Range("Q16").Value


Range("B19").Value = .Range("C16").Value
Range("B20:C20").Value = .Range("E16:F16").Value
Range("B21:C21").Value = .Range("H16:I16").Value
Range("B24").Value = .Range("K16").Value
Range("B25").Value = .Range("H16").Value
Range("B26").Value = .Range("P16").Value
Range("B30").Value = .Range("I23").Value
Range("B31:C31").Value = .Range("K23:L23").Value
Range("B32:C32").Value = .Range("N23:O23").Value
Range("B38:B40").Value = .Range("F28:F30").Value
Range("B42:B44").Value = .Range("F31:F33").Value

Range("D8:D11,D20:D21").FormulaR1C1 = "=RC[-2]*RC[-1]"
Range("D19,D24,D30").FormulaR1C1 = "=R[1]C+R[2]C"
Range("D25:D26,D31:D32,D38:D40,D42:D44,D47:D51,D54:D55").FormulaR1C1 = "=RC[-2]*RC[-1]"

Range("B34").FormulaR1C1 = "=R[-15]C+R[-10]C+R[-4]C"

Range("B14") = .Range("L40").Value + .Range("N40").Value

Range("DQ12").Value = .Range("O40").Value
Range("DR12") = .Range("O40").Value * .Range("Q40").Value
Range("DQ13").Value = .Range("S40").Value
Range("DR13") = .Range("S40").Value * .Range("U40").Value

Range("D14").FormulaR1C1 = "='F1'!R[26]C[8]*'F1'!R[26]C[9]"

Lig_D = Lig_D + 1
End If
End With
Next Lig_S

For Lig_S = 44 To 3 Step -1
With F_S

If F_S.Range("C4").Value = 2 Then
F_D.Select
Application.CutCopyMode = False

.Range("C40,E40,G40,I40").Copy
Range("A1000").Select
ActiveSheet.Paste Link:=True
Selection.Copy
Range("F8").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range("A1000").EntireRow.Delete

.Range(" D40,F40,H40,J40").Copy
Range("A1000").Select
ActiveSheet.Paste Link:=True
Selection.Copy
Range("G8").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range("A1000").EntireRow.Delete

Range("G14").Value = .Range("M40").Value
Range("F47:G51").Value = .Range("C20:D24").Value
Range("F54:G55").Value = .Range("T21:U22").Value
Range("G38:G40").Value = .Range("E28:E30").Value
Range("G42:G44").Value = .Range("E31:E33").Value
Range("G25").Value = .Range("N16").Value
Range("G26").Value = .Range("Q16").Value


Range("F19").Value = .Range("C16").Value
Range("F20:G20").Value = .Range("E16:F16").Value
Range("F21:G21").Value = .Range("H16:I16").Value
Range("F24").Value = .Range("K16").Value
Range("F25").Value = .Range("H16").Value
Range("F26").Value = .Range("P16").Value
Range("F30").Value = .Range("I23").Value
Range("F31:G31").Value = .Range("K23:L23").Value
Range("F32:G32").Value = .Range("N23:O23").Value
Range("F38:F40").Value = .Range("F28:F30").Value
Range("F42:F44").Value = .Range("F31:F33").Value

Range("H8:H11,H20:H21").FormulaR1C1 = "=RC[-2]*RC[-1]"
Range("H19,H24,H30").FormulaR1C1 = "=R[1]C+R[2]C"
Range("H25:H26,H31:H32,H38:H40,H42:H44,H47:H51,H54:H55").FormulaR1C1 = "=RC[-2]*RC[-1]"

Range("F34").FormulaR1C1 = "=R[-15]C+R[-10]C+R[-4]C"

Range("F14") = .Range("L40").Value

Range("DQ12").Value = .Range("O40").Value
Range("DR12") = .Range("O40").Value * .Range("Q40").Value
Range("DQ13").Value = .Range("S40").Value
Range("DR13") = .Range("S40").Value * .Range("U40").Value

Range("H14").FormulaR1C1 = "='F1'!R[26]C[4]*'F1'!R[26]C[5]"

Lig_D = Lig_D + 1
End If
End With
Next Lig_S


Bonjour,

Je n'arrive pas a mettre mon fichier, il est trop lourd même compressé...
 
Dernière édition:
C

Compte Supprimé 979

Guest
Re : repeter macro avec décalage

Bonjour Passiflore et bienvenue sur le forum :)

Plusieurs petites choses :

1) merci de mettre le code dans les balises prévues à cet effet bouton "#"

2) plutôt que de nous innonder d'un code trop long, mieux vaut mettre un fichier avec le code en question

Merci d'éditer ton précédent message, et de nous mettre le/les fichiers en question.

Coridalement.
 

Discussions similaires

Réponses
1
Affichages
1 K

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 846
dernier inscrit
Silhabib