Probleme de copie de cellule vers autre feuille

freyer

XLDnaute Nouveau
Bonjour a tous,


Mon classeur comporte 2 Feuilles. Une feuille "Demande", l'autre "Suivis".
Ma macro compte dans un premier temps le nb de lignes non vide sur la feuille "suivis".
Puis elle cherche des valeurs dans la plage ("E19:E29)
Je souhaite que si une cellule de cette plage n'est pas vide alors cette cellule ainsi que les 3 précedentes de la même ligne soient copier à la suite sur la feuille "Suivis".
Ensuite elle passe à la cellule suivante.

Mon probleme est que la macro copie les dernieres valeurs autant de fois qu'il y a de ligne dans ma plage ("E19:E29) même si la cellule de reference est vide.
Du coups je me retouve avec des doublons.

C'est comme si elle ne prenait pas en compte le IF.

Je joint le fichier en question.

Par avance, merci pour votre aide.


Code:
Sub Suivis()
'
' Suivis Macro
'

'
Dim AjoutSuppr
Dim NumLigne

NumLigne = ActiveCell.Row
F_destination = "Suivis"    'Feuille de destination pour la copie

    Sheets("Suivis").Select     'Selection de la feuille "Suivis"
    
    'Determine le nb de ligne non vide dans la feuille "Suivis"
                nb = 0
                For Each lig In ActiveSheet.UsedRange.Rows
                  If Application.CountA(lig) > 0 Then nb = nb + 1
                Next


    Sheets("Demande").Select 'Selection de la feuille "Demande"
  
    'Boucle sur selection, recherche de valeur et copie dans une seconde feuille
            Set AjoutSuppr = ActiveSheet.Range("E19:E29")
            i = nb + 1
            For Each Cell In AjoutSuppr
            
                If Cell.Value <> "" Then Cell.Select
                    i = i + 1: Cells(2, 10).Value = nb
                    Range("B" & ActiveCell.Row & ":E" & ActiveCell.Row).Copy (Sheets(F_destination).Range("A" & i))
                    Range("E5").Copy (Sheets(F_destination).Range("E" & i)) 'copie la date du jour qui est en E5

                
            Next Cell

                
            
    'Suppression du format des colonnes ABCD
    Sheets("Suivis").Select
                Columns("A:D").Select
                Selection.ClearFormats
    
    End Sub
 

Pièces jointes

  • suivis.xlsm
    22.5 KB · Affichages: 34

Dugenou

XLDnaute Barbatruc
Re : Probleme de copie de cellule vers autre feuille

Deuxieme tentative
et cette fois ci ça marche : le texte apres le if sur la même ligne est celui qui s'applique si vrai
ce qui est en dessous s'applique si faux
corrigé ainsi :
Code:
            For Each Cell In AjoutSuppr
            
                If Cell.Value <> "" Then
                    Cell.Select
                    i = i + 1: Cells(2, 10).Value = nb
                    Range("B" & ActiveCell.Row & ":E" & ActiveCell.Row).Copy (Sheets(F_destination).Range("A" & i))
                    Range("E5").Copy (Sheets(F_destination).Range("E" & i)) 'copie la date du jour qui est en E5
                End If
                
            Next Cell
donne bien 3 lignes
Cordialement
 

Dugenou

XLDnaute Barbatruc
Re : Probleme de copie de cellule vers autre feuille

Re,
Je suis assez nul en vba mais j'ai au moins retenu ceci : le if..then a deux syntaxes
soit tu mets après le then ce qui s'exécute si vrai et à la ligne ce qui s'exécutesi faux et donc pas de end if
soit tu vas à la ligne après then et là tout ce qui est aprés s'exécute si vrai jusqu'au end if
Cordialement
 

Discussions similaires

Statistiques des forums

Discussions
313 283
Messages
2 096 813
Membres
106 752
dernier inscrit
Tahiri1976