Macro excel => Boucle

Résolu
Keny -  
 Keny -
Bonjour,

j'ai effectué une macro excel permettant de déplacer une ligne si une condition est remplie.
je voudrais rajouter une boucle à ma macro pour qu'elle passe en revue toute les lignes de mon tableau ....

Voici ma macro :

Sub archivage()

Dim ligne_active_base As Double

Sheets("suivi").Select
If Range("H3").Value = "F" Then

'Test pour déterminer la ligne où coller les infos dans le tableau'
Sheets("archive").Activate

'Mémorise le n° de la ligne où coller les données'
If Range("A3").Value = "" Then
ligne_active_base = Range("A3").Row
Else
ligne_active_base = Range("A3").End(xlDown).Row + 1
End If

'Atteindre le formulaire et mémoriser les données'
Sheets("suivi").Range("B3:H3").Copy
Range("A" & ligne_active_base).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Collage sans transposition'
Application.CutCopyMode = False
Range("G3").ClearContents

'Rendre le formulaire vierge'
Sheets("suivi").Activate
Sheets("suivi").Range("B3:H3").ClearContents
Sheets("suivi").Range("B3").Select

'Retourner sur la base de données'
Sheets("archive").Activate

End If

End Sub

Cette macro traite seulement la ligne 3 (B3:H3) de mon tableau ...
je voudrais que la boucle réitère l'opération pour les lignes 3 à 21 (B21:H21)

Merci d'avance de votre aide

Cordialement,
Keny

1 réponse

  1.
    gbinforme Messages postés 14930 Date d'inscription   Statut Contributeur Dernière intervention   4 744
     
    bonjour

    Je te propose ceci qui devrait faire ce que tu souhaites : 

    Sub archivage()

Dim lignes As Object
For Each lignes In Sheets("suivi").Columns("H").Cells
    If lignes.Value = "F" Then
        Sheets("suivi").Cells(lignes.Row, 2).Resize(1, 6).Copy
        Sheets("archive").Cells(Range("A65532").End(xlUp).Row + 1, 1).PasteSpecial _
        Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Sheets("suivi").Cells(lignes.Row, 2).Resize(1, 7).ClearContents
    End If
Next lignes
Application.CutCopyMode = False
End Sub

    tu sélectionnes toutes les lignes avec "F" en colonne H et tu les archives.
    0
    1. Keny
       
      Bonjour,

      jai testé ta solution, elle me semble judicieuse. seul problème, si j'ai selectionné 4 ligne avec le "F" , elle me les déplace dans archive, mais toutes sur la meme ligne ... donc la derniere écrase tout le reste ...

      je voudrais que dans "archive" qu'il colle les données a partir de "A3" , en passant par "A4" si A3 n'est pas vierge.

      merci !
      0
    2. gbinforme Messages postés 14930 Date d'inscription   Statut Contributeur Dernière intervention   4 744
       
      bonjour,

      Ta feuille archive n'ai pas bien enregistrée : tu as des lignes vides après tes données.

      Il faut les sélectionner en te mettant sur la première puis faire majuscule + ctrl + fin et clic droit supprimer puis tu sauvegardes, tu fermes et tu recommences, cela devrait fonctionner.
      0
    3. Keny
       
      Bonjour,

      j'ai essayé cke tu m'a dit de faire, mais ca change rien ...
      je t'envoie le lien ca sera plus simple ...
      dans l'onglet suivi ta un onglet "archivage" ki permet d'executer la macro.

      http://www.cijoint.fr/cjlink.php?file=cj201005/cij4f7Vg7U.xls

      Merci
      0
    4. Keny
       
      dsl jvoulai dire, un boutton "archivage"
      0
    5. gbinforme Messages postés 14930 Date d'inscription   Statut Contributeur Dernière intervention   4 744
       
      bonsoir,

      Au temps pour moi, il manque une qualification et il faut rajouter le paramètre gras 
              Sheets("archive").Cells(Sheets("archive").Range("A65532").End(xlUp).Row + 1, 1).PasteSpecial _ 
        Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

      ou plus correct et simple 
      Sub archivage()
Dim lignes As Object
Application.ScreenUpdating = False
With Sheets("archive")
For Each lignes In Sheets("suivi").Columns("H").Cells
    If lignes.Value = "F" Then
        Sheets("suivi").Cells(lignes.Row, 2).Resize(1, 6).Copy
        .Cells(.Range("A65532").End(xlUp).Row + 1, 1).PasteSpecial _
        Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Sheets("suivi").Cells(lignes.Row, 2).Resize(1, 7).ClearContents
    End If
Next lignes
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
      0

Discussions similaires

Transformer un chiffre en lettres dans excel sans macro
vincentphilippos -
tontong -

6 réponses