copier cellule toutes les 47 lignes

[jean paul]

bonsoir

j'ai ecris ce bout de code mais serait il possible de le simplifier les lignes en rouge

en effet veux copier des cellule en colonne I à partir de I16 avec un pas de 47
idem pour la collonne G en commencant par la cellule G36

Cordialement JEAN PAUL

Sheets("momo").Select

'copie designation
Range("i16,i63,i110,i157,i204,i251,i298,i345,i392,i439,i486,i533,i580,i627,i674,i721,i768,i815,i862,i909").Select

Selection.Copy
Sheets("feuil2").Select
Range("C1").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("momo").Select

'copie QUANTITE
Range("g36,g83,g130,g177,g224,g271,g318,g365,g412,g459,g506,g553,g600,g647,g694,g741,g788,g835,g882,g929").Select

Selection.Copy
Sheets("feuil2").Select
Range("D1").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

 

[tototiti2008]

Re : copier cellule toutes les 47 lignes

Bonjour jean paul,

une possibilité :

Dim Adresses As String, i As Long
Adresses = ""
For i = 16 To 909 Step 47
Adresses = Adresses & "I" & i
If i <> 909 Then Adresses = Adresses & ","
Next i
ActiveSheet.Range(Adresses).Copy


Ceci dit, il serait plus efficace d'éviter les Select pour les plages :

ActiveSheet.Range(Adresses).Copy
Sheets("feuil2").Select
Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

 

[Robert]

Re : copier cellule toutes les 47 lignes

Bonjour Jean-Paul, Tototiti, bonjour le forum,

Plus le temps de commenter car c'est l'heure où je fuis du boulot... Ce bout de code à inserer dans le tien :

Sub Macro1()
Dim pl As Range
Dim pl2 As Range
Dim i As Integer
Dim j As Integer
Set pl = Range("I16")
For i = 63 To 909 Step 47
    Set pl = Application.Union(pl, Range("I" & i))
Next i
Set pl2 = Range("G36")
For j = 83 To 929 Step 47
    Set pl2 = Application.Union(pl2, Range("I" & j))
Next i
End Sub

 

[skoobi]

Re : copier cellule toutes les 47 lignes

Bonjour,

Je te propose ce code à la place (si j'ai bien compris):

Sub copie()
  Sheets("momo").Select
  'copie designation
  With Sheets("feuil2")
    For lig = 16 To 909 Step 47
      ligsuiv = .Range("C65536").End(xlUp).Row + 1
      .Range("C" & ligsuiv).Value = Range("I" & lig).Value
    Next

    'copie QUANTITE
    For lig = 36 To 929 Step 47
      ligsuiv = .Range("D65536").End(xlUp).Row + 1
      .Range("D" & ligsuiv).Value = Range("G" & lig).Value
    Next
  End With
  Sheets("feuil2").Select
End Sub

Edit: arfff, Robert, que je salue, a 2 mn d'avance sur moi.... et tototiti bien entendu

 

[Cousinhub]

Re : copier cellule toutes les 47 lignes

Bonsoir,

bonsoir, le fil

à mon tour, un petit code :

For i = 1 To 20
Sheets("feuil2").Cells(i, 3).Value = Sheets("momo").Cells(16 * ((i - 1) * 47), 9).Value
Sheets("feuil2").Cells(i, 7).Value = Sheets("momo").Cells(36 * ((i - 1) * 47), 9).Value
Next i

 

[jean paul]

Re : copier cellule toutes les 47 lignes

🙂Bonjour
quel bonheur de decouvrir tant de réponses,donc je me mets au travail
merci à tous pour vos réponses
cordialement
JP