Création d'une répétition

Bonjour à tous,

Le code ci-dessous, me permet de remplacer les valeurs de 2 lignes si une condition est respectée. Autrement dis :

Si il n'y a pas de valeur dans B7, il copie les lignes A25:R26 de la feuille "Calcul modele" sur la cellule A28 de la feuille "Débit".

Dans le cas contraire, il copie les lignes A27:R28 de la feuille "Calcul modele" sur la cellule A28 de la feuille "Débit".

Ma question, j'aimerais faire en sorte que ce code ce répète à l'infini avec un écart de 29 lignes plus bas.

Du coup la condition ce porterait sur B7, B36, B65, ....

Option Explicit

Sub calcul_des_surfaces()

Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("Débit")

If Cells(7, 2) = "" Then

    Sheets("Calcul modele").Select
    Range("A25:R26").Select
    Selection.Copy

    Sheets("Débit").Select
    Range("A28").Select
    ActiveSheet.Paste

Else

    Sheets("Calcul modele").Select
    Range("A27:R28").Select
    Selection.Copy

    Sheets("Débit").Select
    Range("A28").Select
    ActiveSheet.Paste

End If
End Sub

Merci d'avance :)

Bonjour SOTIN,

L'on boucle sur ... B7, B36, B65, ....

Si l'on copie Sheets("Calucul modele").Range("A25:R26") en Sheets("Débit).Range("A28:R29")

Est-ce toujours : Sheets("Calucul modele").Range("A25:R26") copié en Sheets("Débit).Range("A28 (+29, +58, etc.) :R29 (+29, +58 , etc.) ")

ric

Bonjour ric, présent sur tous les front ! 😁

La feuille de départ c'est "Débit"

A+

Bonjour SOTIN,

Si ce sont toujours les mêmes lignes de la feuille "Calcul modele" que l'on copie ...

Sub calcul_des_surfaces()
   Dim WS As Worksheet, X As Integer

    Set WS = ThisWorkbook.Sheets("Débit")
   For X = 7 To WS.Cells(Rows.Count, "B").End(xlUp).Row Step 29   ' ajuster la colonne où l'on devrait trouver la dernière ligne ... si pas "B"

      If WS.Cells(X, 2) = "" Then
         WS.Range("A" & X + 21 & ":R" & X + 22).Value = Sheets("Calcul modele").Range("A25:R26").Value
      Else
         WS.Range("A" & X + 21 & ":R" & X + 22).Value = Sheets("Calcul modele").Range("A27:R28").Value
      End If
   Next X
End Sub

ric

Re,

J'ai copier/coller ton code, il n'y a pas de message d'erreur qui apparait mais rien ne se produit. Je dois m'absenter, je m'y remets dès mon retour.

A+

Bonjour SOTIN,

Je pense que je n'était pas vraiment réveillé ...

ric

Re,

J'ai réussi à produire quelque chose en rajoutant End(xlUp).Row juste avant Step 29

Mais ça ne fait pas de boucle, la copie n'opère qu'une seule fois. Je te joins le code entier.

Option Explicit

Sub calcul_des_surfaces()

Dim WS As Worksheet, X As Integer

Set WS = ThisWorkbook.Sheets("Débit")

For X = 7 To WS.Cells(Rows.Count, "B").End(xlUp).Row Step 29

If WS.Cells(X, 2) = "" Then

    Sheets("Calcul modele").Select
    Range("A25:R26").Select
    Selection.Copy

    Sheets("Débit").Select
    Range("A28").Select
    ActiveSheet.Paste

Else

    Sheets("Calcul modele").Select
    Range("A27:R28").Select
    Selection.Copy

    Sheets("Débit").Select
    Range("A28").Select
    ActiveSheet.Paste

End If
Next X

End Sub

Merci ;)