Discussion :

[olive08]

Bonjour,

Je voudrais faire un programme VBA qui me permette de copier les lignes d'une feuille vers une autre dans le même classeur en fonction de condition sur 2 colonnes différentes.

Si ma la valeur de la cellule x présente dans la colonne BQ = "a" et la valeur de la cellule y présente dans la colonne BR = b (ou c ou d ...) alors copier cette ligne dans l'autre feuille.

J'ai fais un code mais le problème est que la macro copie seulement la première ligne ou une des condition est remplie puis il s'arrete et ne valide pas les autres condition jusqu'a la fin du tableau???

Je vous remercie pour votre aide

voici mon 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
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
Sub checkinterco()
 
Dim i As Integer
Dim j As Integer
j = 6
 
 
Worksheets("Feuil1").Range("A7:CP2000").ClearContents
 
 
Sheets("SFORL West Europe CS - TMN C4").Select
    ActiveWindow.SelectedSheets.Delete
 
    Workbooks.Open Filename:="D:\Mes Documents\funnel highlight\spade data_last week.xls"
    Sheets("SFORL West Europe CS - TMN C4").Select
    Sheets("SFORL West Europe CS - TMN C4").Copy After:=Workbooks("checkintrainterflag.xls").Sheets(1)
    Windows("spade data_last week.xls").Activate
    ActiveWindow.Close
 
 
Worksheets("SFORL West Europe CS - TMN C4").Select
Rows("1:1").Select
Selection.AutoFilter
Range("CP1").Value = "Check interco"
 
 
'external
For i = 2 To 2000
 
        If Cells(i, 69).Value = "None" And Cells(i, 70).Value <> "N/A" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
'intersbu
 
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "Sogeti" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
 
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "CEA - Finland TS OS" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "CEA - CE TS GE/CH" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "CEA - CEA CS" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "CEA - Netherlands TS" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "CEA - Belgium TS" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "CEA - Eastern Europe" Then
        Rows(i).Copy
        Sheets("Feuil1").Range("A" & i).Select
        ActiveSheet.Paste
        End If
 
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "OS - OS Europe" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
 
'intrasbu
 
        If Cells(i, 69).Value = "Intra SBU" And Cells(i, 70).Value <> "WE - France TS" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
        If Cells(i, 69).Value = "Intra SBU" And Cells(i, 70).Value <> "WE - WE CS" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
        If Cells(i, 69).Value = "Intra SBU" And Cells(i, 70).Value <> "WE - Iberia TS OS" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
'intragou
 
 
        If Cells(i, 69).Value = "Intra GOU" And Cells(i, 70).Value = "FR Capgemini CS" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
Next i
        j = j + 1
 
 
 
End Sub

[Jean-Philippe André]

bonjour, ton j=j+1 devrait figurer dans ta boucle non ?

[ouskel'n'or]

Bonjour
Bienvenue sur le forum.
Deux choses : Si tu ne sélectionnes pas le fichier de copie, après le premier collage, le fichier que tu viens de sélectionner reste le fichier actif... Tu ne trouves donc pas ta donnée et elle ne sera jamais collée.
Seconde chose : Ta syntaxe

Rows(i).Copy
Sheets("Feuil1").Select
Range("A" & j).Select
ActiveSheet.Paste

peut être simplifiée et ainsi régler le problème.
Je suppose que la feuille dans laquelle tu copies les données est "Worksheets("SFORL West Europe CS - TMN C4")."
et celle dans lequel tu colles est Sheets("Feuil1")
Je passe sur l'ouverture et reprends à partir de ActiveWindow.Close

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
    ActiveWindow.Close
Dim Fl1 as Worksheet
Dim Fl2 as Worksheet
    Set FL1 = Worksheets("SFORL West Europe CS - TMN C4")
    Set FL2 = Worksheets("Feuil1")
    FL1.Rows("1:1").AutoFilter
    FL1.Range("CP1").Value = "Check interco"
 
'external
For i = 2 To 2000
 
        If FL1.Cells(i, 69).Value = "None" And FL1.Cells(i, 70).Value <> "N/A" Then
             FL1.Rows(i).Copy FL2.Range("A" & j)
        End If
 
'intersbu
 
        If FL1.Cells(i, 69).Value = "Inter SBU" And FL1.Cells(i, 70).Value <> "Sogeti" Then
             FL1.Rows(i).Copy FL2.Range("A" & j)
        End If
'etc.

On n'a jamais (sauf exception) à sélectionner une feuille ou une cellule pour modifier leurs données. Le code ci-dessus accélère les procédures et simplifie l'écriture (et donc la relecture)
A+

[olive08]

Merci beaucoup pour votre aide.
Le code est effectivement plus facile à comprendre comme ça.

Cependant il ne marche toujours pas.
Il copie toujours qu'une seule ligne (qui ne devrait pas l'être).

j'ai essayé en mettant un j=j+1 à la fin de chaque if mais ca ne donne rien...
je ne sais pas si je le met au bon endroit ni pourquoi la macro copie une valeur incorecte???

Voici la fin du code:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
'intragou
 
        If Fl1.Cells(i, 69).Value = "Intra GOU" And Fl1.Cells(i, 70).Value = "FR Capgemini CS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
        End If
 
Next i
       j = j + 1
       Fl2.Activate
 
End Sub

[Invité]

Bonjour Olive08,

Code :

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

1
2
3
Next i
j = j + 1
Fl2.Activate

j = j + 1 pacé après Next i à priori ne sert à rien. Il faut le mettre avant Next i

Code :

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

1
2
3
4
j = j + 1
Next i
 
Fl2.Activate

[Oh!Tofocus]

Salut
je m'interroge sur la pertinance de ton code
as-tu bien analysé les conditions ?

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "CEA - CE TS GE/CH" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If
 
        If Cells(i, 69).Value = "Inter SBU" And Cells(i, 70).Value <> "CEA - CEA CS" Then
        Rows(i).Copy
        Sheets("Feuil1").Select
        Range("A" & j).Select
        ActiveSheet.Paste
        End If

les 2 test s'annulent et dans tous les car de figure si "inter SBU" est OK
la ligne est copiée dans "feuille1"
et le test <> ne sert a rien