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

[Oh!Tofocus]

je persiste

si la valeur est "CEA - CE TS GE/CH" la copie se fait au deuxieme test
si la valeur est "CEA - CEA CS" la copie se fait au premier test
si la valeur n'est ni "CEA - CE TS GE/CH" ni "CEA - CEA CS" la copie se fait 2 fois au même endroit aux 2 tests
et bonsoir pour l'incrementation de j si elle est dans chaque test

dans tous les cas si Cells(i, 69).Value = "Inter SBU" est vrai ... la copie se fait

[Invité]

Bonsoir à tous,

Je pense que Oh!Tofocus a cerné sinon tout le problème, au moins une partie du problème.

En effet :

Code :

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

j = j + 1

ne devrait pas se trouver seulement avant "Next i" mais avant chaque "End If".

Ensuite il reste a voir si les différents "If" ne sont pas contradictoires cela étant un peu long à vérifier par la complexité du contenu des cellules (par exemple les espaces un peu partout qui peuvent induirent une erreur).

[ouskel'n'or]

Oh!Tofocus, tu as raison. J'avais encore mal lu.
Quant au J+1 il doit être mis chaque fois qu'une copy est réalisée, et effectivement dans le IF ....... Endif, avant ou après collage selon l'init du début.
Bonne soirée

[Invité]

Bonsoir Ouskel'n'or,

Et oui, nous connaissons tous ce problème.

Souvent c'est le demandeur qui ne donne pas assez de détails.

Parfois c'est le répondeur qui n'a pas bien lu le détail de la question.

C'était aussi mon cas ici.

Mais il reste le côté positif : nous participons tous à l'approche de la solution (en tout cas je l'espère).

[olive08]

j'ai essayé avec le j=j+1 dans la boucle et ca marche un peu mieux (il copie beaucoup plus de ligne) malheureusement beaucoup trop.

la macro copie des la meme lignes plusieurs fois et effectivement puisque il ya plusieurs boucle if à la suite il copie d'abord les lignes qui font référence à la première condition.

ex: pour les intrasbu

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
'intrasbu
        If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - France TS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
 
        If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - WE CS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
 
        If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - Iberia TS OS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If

la macro copie d'abord 3 fois la meme ligne (qui doit effectivement etre copiée puisque les condition sont remplies (colonne BQ = intra SBU et colonne BR = CEA...) mais après j'ai 2 lignes suivantes qui sont les meme(collonne BQ = intra SBU et colonne BR = WE - France TS) alors que dans le code je demande bien de ne pas copier ces lignes.

Bref. le gros problème viens de l'imbrication des IF.

J'ai essayé avec un code du style

Code :

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

If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - France TS" Or Fl1.Cells(i, 70).Value <> "WE - WE CS" Or ...

pour que toutes les conditions de la deuxième colonne soit à la suite mais ca ne marche pas non plus...

Est ce qu'il y a une autre manière de faire celà (enfin de le dire correctement).


Je renvoie un message avec le code tel qu'il est actuellement pour y voir plus clair.

merci pour vos réponse.

[olive08]

voila le 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
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
 
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)
             j = j + 1
        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)
             j = j + 1
        End If
 
        If Fl1.Cells(i, 69).Value = "Inter SBU" And Fl1.Cells(i, 70).Value <> "CEA - Finland TS OS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
        If Fl1.Cells(i, 69).Value = "Inter SBU" And Fl1.Cells(i, 70).Value <> "CEA - CE TS GE/CH" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
        If Fl1.Cells(i, 69).Value = "Inter SBU" And Fl1.Cells(i, 70).Value <> "CEA - CEA CS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
        If Fl1.Cells(i, 69).Value = "Inter SBU" And Fl1.Cells(i, 70).Value <> "CEA - Netherlands TS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
        If Fl1.Cells(i, 69).Value = "Inter SBU" And Fl1.Cells(i, 70).Value <> "CEA - Belgium TS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
        If Fl1.Cells(i, 69).Value = "Inter SBU" And Fl1.Cells(i, 70).Value <> "CEA - Eastern Europe" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
        If Fl1.Cells(i, 69).Value = "Inter SBU" And Fl1.Cells(i, 70).Value <> "OS - OS Europe" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
 
'intrasbu
        If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - France TS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
        If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - WE CS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
        If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - Iberia TS OS" Then
             Fl1.Rows(i).Copy Fl2.Range("A" & j)
             j = j + 1
        End If
 
 
'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)
             j = j + 1
        End If
 
Next i
 
       Fl2.Activate
 
End Sub

[Invité]

Bonjour Olive08,

Si on décortique ce cas précis :

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
'intrasbu
If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - France TS" Then
Fl1.Rows(i).Copy Fl2.Range("A" & j)
j = j + 1
End If
 
If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - WE CS" Then
Fl1.Rows(i).Copy Fl2.Range("A" & j)
j = j + 1
End If
 
If Fl1.Cells(i, 69).Value = "Intra SBU" And Fl1.Cells(i, 70).Value <> "WE - Iberia TS OS" Then
Fl1.Rows(i).Copy Fl2.Range("A" & j)
j = j + 1
End If

Dans la mesure où la ligne traitée contient bien en colonne 69 "Intra SBU" et que la colonne 70 ne peut que contenir :

"WE - France TS" ou
"WE - WE CS" ou
"WE - Iberia TS OS"

si je comprends bien il ne peut y avoir que 2 lignes de copiées ?

mais vous ecrivez :

la macro copie d'abord 3 fois la meme ligne (qui doit effectivement etre copiée puisque les conditions sont remplies (colonne BQ = intra SBU et colonne BR = CEA...) mais après j'ai 2 lignes suivantes qui sont les meme(collonne BQ = intra SBU et colonne BR = WE - France TS) alors que dans le code je demande bien de ne pas copier ces lignes


donc avec "Intra SBU" on peut trouver autre chose que les 3 données inscrites ci-dessus ?

dans ce cas je ne vois pas pourquoi la copie serait > à 3 lignes sauf à vérifier la 1ère condition :

Code :

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

If Fl1.Cells(i, 69).Value = "None" And Fl1.Cells(i, 70).Value <> "N/A" Then

Avez-vous essayé de mettre un point d'arrêt sur cette ligne puis avec F8 vous passez chaque instruction en pas-à-pas ce qui doit vous permettre de voir où se passe l'anomalie (vous pouvez décaler la fenêtre VBA vers la droite et/ou vers le bas de manière à voir une partie de la feuille et donc ce qui se passe).

[ouskel'n'or]

Sans approfondir, tu peux déjà simplifier ton code en ne mettant qu'une seule fois

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
'intersbu
If Fl1.Cells(i, 69).Value = "Inter SBU" Then
 
'ici ton code corrigé pour remplacer le suivant... puisque tout le monde t'a 
' dit que ça ne pouvait pas fonctionner 
 
    If Fl1.Cells(i, 70).Value <> "Sogeti" Then
         Fl1.Rows(i).Copy Fl2.Range("A" & j)
         j = j + 1
    End If
 
    If Fl1.Cells(i, 70).Value <> "CEA - Finland TS OS" Then
         Fl1.Rows(i).Copy Fl2.Range("A" & j)
         j = j + 1
    End If
 
    If Fl1.Cells(i, 70).Value <> "CEA - CE TS GE/CH" Then
         Fl1.Rows(i).Copy Fl2.Range("A" & j)
         j = j + 1
    End If
 
    If Fl1.Cells(i, 70).Value <> "CEA - CEA CS" Then
         Fl1.Rows(i).Copy Fl2.Range("A" & j)
         j = j + 1
    End If
 
'etc
 
Endif

Ça t'évitera un test pour chaque ligne

Tu aurais d'ailleurs une méthode plus rapide consistant à utiliser Find sur "Inter SBU" ou

Code :

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

for each cel in FL1.range(cells(2,69), cells(2000, 69))

mais je n'ai pas le tps de développer ni de voir ça en détail.
Mais JacquesJean verra bien si c'est possible (Salut JacquesJean)
Bonne après midi

[olive08]

Jacques,
la première condition est bonne puisque dès le départ (et après test) aucune valeur n'été copiée dans le tableau. Ce qui est normal puisque aucune valeur ne doit être copié (l'association est toujours bonne).


ouskel'n'or la ligne que tu propose signifi un peu la rédaction mais la condition doit être valable au noveau des 2 colonnes (69 et 70). De plus je ne peut pas lui dire (à excel) quelle ligne il doit copier. Si j'utilise 'Entirerow.copy' il me met un message d'erreur "methode introuvable".

Je joint un fichier excel avec les 2 colonnes et commentaires pour que ce que je veut faire soit vraiment cliar pour vous (un petit exemple vaux mieux que mes longs discours)

[Invité]

Re Oliver08,

Pour ce que Ouskel'n'or propose on y reviendra ensuite car il a raison, on peut clarifier le code.

J'ai recopié votre code dans un fichier Excel sur lequel j'ai créé 2 feuilles.
Sur la 1ère j'ai entré uniquement des données correspondants exactement aux associations que vous prévoyez :

-pour Inter SBU j'avais bien 7 lignes de copiées pour chaque donnée correspondante. Ce qui est normal puisque vous passez par 8 comparaisons.

-pour Intra SBU j'avais bien 7 lignes de copiées pour chaque donnée correspondante. Ce qui est normal puisque vous passez par 8 comparaisons.

etc.....

Mais j'ai regardé votre fichier et je ne comprends toujours pas :

Dans votre tableau vous précisez que "Inter SBU" ne peut contenir que les 8 cas indiqués or à partir de la ligne 44 on trouve 2 "WE - France TS" et 3 "WE - WE CS" qui ne peuvent être en principe contenus que dans "Intra SBU"

Est-ce justement ces cas que vous voulez trouver ?

Si oui le code n'est pas du tout adapté ou je n'ai rien compris.

[Invité]

Re,

Je crois avoir compris et si c'est le cas ce code devrait fonctionner car votre code d'orgine testait chaque combinaison une par une et évidemment pour 3 comparaisons vous aviez au moins 2 lignes copiées inutilement et pour 8 au moins 7 lignes dans le même cas :

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
Sub checkinterco()
Dim i As Integer
Dim j As Integer
Dim t1$, t2$, t3$, t4$, t5$, t6$, t7$, t8$, t9$, t10$, t11$
 
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
 
j = 6
t1 = "Sogeti"
t2 = "CEA - Finland TS OS"
t3 = "CEA - CE TS GE/CH"
t4 = "CEA - CEA CS"
t5 = "CEA - Netherlands TS"
t6 = "CEA - Belgium TS"
t7 = "CEA - Eastern Europe"
t8 = "OS - OS Europe"
t9 = "WE - France TS"
t10 = "WE - WE CS"
t11 = "WE - Iberia TS OS"
 
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)
j = j + 1
End If
 
'intersbu
If Fl1.Cells(i, 69).Value = "Inter SBU" Then
     If Fl1.Cells(i, 70) <> t1 And Fl1.Cells(i, 70) <> t2 And Fl1.Cells(i, 70) <> t3 And Fl1.Cells(i, 70) <> t4 _
     And Fl1.Cells(i, 70) <> t5 And Fl1.Cells(i, 70) <> t6 And Fl1.Cells(i, 70) <> t7 And Fl1.Cells(i, 70) <> t8 Then
     Fl1.Rows(i).Copy Fl2.Range("A" & j)
     j = j + 1
     End If
End If
 
'intrasbu
If Fl1.Cells(i, 69).Value = "Intra SBU" Then
    If Fl1.Cells(i, 70) <> t9 And Fl1.Cells(i, 70) <> t10 And Fl1.Cells(i, 70) <> t11 Then
    Fl1.Rows(i).Copy Fl2.Range("A" & j)
    j = j + 1
    End If
End If
 
'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)
j = j + 1
End If
 
Next i
Fl2.Activate
End Sub

[olive08]

Extraordinaire ca marche.

Merci beaucoup pour votre aide, j'espère que je pourrais bientôt en faire autant pour d'autre débutant en VBA.

[Invité]

Bonjour Olive08,

Content d'avoir pu participer à la solution, avec d'autres.
Vous aurez remarqué je pense l'importance de bien cerner le problème et comme vous l'avez fait en final d'apporter un exemple.

Si vous le voulez bien indiquez "Résolu" sur votre sujet.

Amicalement.