[VBA]Boucle : copier 2 fois une cellule et recommencer jusqu'à la fin de la coloRésolu

Question

Bonsoir
Je butte sur une bétise de boucle.
Voila je chercher à copier 2 fois la première cellule A1 FRED dans A2 et A3 puis 2 fois la 4 ème cellule A4 PAUL dans A5 et A6 et comme cela jusqu'à la fin de la colonne.
A1 FRED
A2
A3
A4 PAUL
A5
A6
A7 JEAN
A8
A9

j'ai commencer un code mais cela ne fonctionne pas.Pouvez vous m'aider please!!


Sub copier_cellules()
  Range("F2").Select                ' sélectionne e champ
  Do While ActiveCell <> ""
    Selection.Copy
    Selection.Offset(1, 0).Select      ' Curseur en dessous
    ActiveSheet.Paste
    Selection.Copy
    Selection.Offset(1, 0).Select      ' Curseur en dessous
    ActiveSheet.Paste
  Loop
End Sub

Merci

ucfoutu · Accepted Answer

Bonjour,
que faut ta discussion dans le thème  Forum > Visual Basic 6 > Diversalors que selon toute apparence tu développes sous VBA/Excel ?
Tu aurais du l'ouvrir dans le thème (note-le bien pour les fois suivantes) : Langages dérivés > VBA

On ne travaille pas à coups de Select > coy > paste ! (évite ce genre de procédé).

Regarde ce que fait ceci, tout bêtement (avec ton exemple ) :

 Dim derlig As Long, i As Long, j As Integer
With Sheets("Feuil1")
  derlig = .Range("A" & Rows.Count).End(xlUp).Row
  For i = 1 To derlig Step 3
    For j = 1 To 2
      .Range("A" & i + j).Value = .Range("A" & i)
    Next
  Next
End With

Ni select, ni copy, ni paste !

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

ucfoutu · Answer

Tiens (toujours sans ces select, copy, paste) ===>>
En voilà une autre, juste pour t'ouvrir des horizons. Elle est plus "rigolote"
Dim toto As Range, titi As Range, derlig As Long
With Sheets("Feuil1")
  derlig = .Range("A" & Rows.Count).End(xlUp).Row
  On Error Resume Next ' (pour le cas où tout serait déjà rempli)
  Set toto = .Range("A1:A" & derlig + 2).SpecialCells(xlCellTypeBlanks)
  If Not toto Is Nothing Then
    For Each titi In toto
      titi.Value = titi.Offset(-1, 0).Value
    Next
  End If
End With

Tu vois ? 
On pourrait en faire d'autres encore 

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

ucfoutu · Answer

Tiens en voilà encore une.
Celle-ci (comme d'ailleurs la précédente), remplira les blancs avec ce qui se trouve au-dessus (quel que soit le nombre de blancs) :
Dim i As Long, derlig As Long
With Sheets("Feuil1")
  derlig = .Range("A" & Rows.Count).End(xlUp).Row
  For i = 1 To derlig
       If .Range("A" & i).Value "" Then .Range("A" & i).Value  .Range("A" & i).Offset(-1, 0).Value
  Next
End With
Cette méthode pourra te paraître plus simple (en ce qui concerne le code). Elle est toutefois légèrement plus lente que les deux premières).

Si, par ailleurs, le nombre de lignes à traiter est très important, dis-le et on passera à une méthode  encore autre  hyper-rapide (utilisation d'un tableau dynamique).



________________________
Réponse exacte ?  => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

broglienew · Answer

Merci beaucoup !!
Je ne te fais pas la bise mais le coeur y est.
Slt

[VBA]Boucle : copier 2 fois une cellule et recommencer jusqu'à la fin de la colo

4 réponses

Votre réponse

Discussions similaires