Discussion :

[Mal's]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Invité]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Mal's]

Eric KERGRESSE Merci beaucoup ! Sa marche parfaitement !

Cordialement