Macro de copie de cellules

Version imprimable

Bonjour ,

J'ai un souci assez similaire , je souhaite copier une cellule en fonction d'un critère d'une autre cellule pour les copier dans une autre page , ma macro fonctionne bien mais elle ne s'applique seulement une seule fois , je m'explique :

J'ai un tableau dans ma feuille "Sujets" avec une liste de sujet en colonne A avec une liste de nom en colonne B , je souhaite qu'à chaque fois que le nom Adrien apparaît en colonne B la cellule de la colonne A lui correspondant se copie et se colle dans ma feuille nommé "Adrien" dans la cellule C3 , mon souci est que lorsque j'ai deux fois le nom Adrien qui apparaît , ma macro ne s'applique seulement au 1er et non au deuxième qui devrait se coller dans la cellule C4.

Code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 Sub Tableau() Sheets("Sujets").Select For i = 1 To 100 If Cells(i + 4, 2).Value = "Adrien" And Not IsEmpty(Cells(i + 4, 2)) Then Cells(i + 4, 1).Copy Sheets("Adrien").Select Cells(3, 3).Select ActiveSheet.Paste If Cells(i + 4, 2).Value = "Adrien" And Not IsEmpty(Cells(i + 4, 2)) Then Cells(i + 4, 1).Copy Sheets("Adrien").Select Cells(4, 3).Select ActiveSheet.Paste End If Next End Sub
Cordialement

Citation:

Envoyé par Mal's

Bonjour,

Cette discussion est résolue, la prochaine fois créez une nouvelle discussion et encadrez le code avec les balises #.

Essayez ce code (pas testé) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
Sub Tableau()
 
Dim ShSource As Worksheet, ShCible As Worksheet
Dim I As Long, LigneEnCoursCible As Long
 
    Set ShSource = Sheets("Sujets")
    Set ShCible = Sheets("Adrien")
    LigneEnCoursCible = 3
 
    With ShSource
         For I = 5 To 105
             If .Cells(I, 2) = "Adrien" Then
                ShCible.Cells(LigneEnCoursCible, 3) = .Cells(I, 1)
                LigneEnCoursCible = LigneEnCoursCible + 1
             End If
        Next
 
    End With
 
    Set ShSource = Nothing
    Set ShCible = Nothing
 
End Sub

31/01/2017, 10h50
Mal's

Eric KERGRESSE Merci beaucoup ! Sa marche parfaitement !

Cordialement