Supprimer lignes selon contenu cellule --> ne fonctionne pas sur 1 page /4

[Fredox]

Bonjour,

J'ai mis en place ce code pour copier 4 feuilles existantes et filtrer le contenu selon le contenu de la page index, en F7
Cela fonctionne très bien sur les 3 premières feuilles, en revanche sur la 4ème, les données sont complètes, le filtrage du contenu ne se fait pas.
C'est pourtant le même code pour les 4 feuilles.

Un coup de main est possible ?

Merci.

' ***-------------------------------------------------------------***
Worksheets("__ 01 __").Copy After:=Sheets(Worksheets.Count)
Set MySheet1 = ActiveSheet
With MySheet1
   .Name = "01_ " & Worksheets("index").Range("F7")
End With

Dim a$, b&, c&
Dim Secteur As String
Secteur = Sheets("index").Range("K2")

c = Cells(3000, 8).Row
For b = c To 4 Step -1
a = Cells(b, 8).Value
If Not (Cells(b, 8) Like (Secteur)) Then Rows(b).Delete
Next

MySheet1.Tab.ColorIndex = 1

' ***-------------------------------------------------------------***
Worksheets("__ 02 __").Copy After:=Sheets(Worksheets.Count)
Set MySheet2 = ActiveSheet
With MySheet2
   .Name = "02_ " & Worksheets("index").Range("F7")
End With

Dim d$, e&, f&

f = Cells(3000, 8).Row
For e = f To 4 Step -1
d = Cells(e, 8).Value
If Not (Cells(e, 8) Like (Secteur)) Then Rows(e).Delete
Next

MySheet2.Tab.ColorIndex = 1

' ***-------------------------------------------------------------***
Worksheets("__ 03 __").Copy After:=Sheets(Worksheets.Count)
Set MySheet3 = ActiveSheet
With MySheet3
   .Name = "03_ " & Worksheets("index").Range("F7")
End With

Dim g$, h&, i&

i = Cells(3000, 8).Row
For h = i To 4 Step -1
g = Cells(h, 8).Value
If Not (Cells(h, 8) Like (Secteur)) Then Rows(h).Delete
Next

MySheet3.Tab.ColorIndex = 1

' ***-------------------------------------------------------------***
Worksheets("__ 04 __").Copy After:=Sheets(Worksheets.Count)
Set MySheet4 = ActiveSheet
With MySheet4
   .Name = "04_ " & Worksheets("index").Range("F7")
End With

Dim m$, n&, o&

o = Cells(3000, 8).Row
For n = o To 4 Step -1
m = Cells(n, 8).Value
If Not (Cells(n, 8) Like (Secteur)) Then Rows(n).Delete
Next

 

[Fredox]

Ouff,

J'ai changé de méthode, ca fonctionne très bien maintenant.

Merci

' ***-------------------------------------------------------------***
Worksheets("__ 01 __").Copy After:=Sheets(Worksheets.Count)
Set MySheet1 = ActiveSheet
With MySheet1
   .Name = "01_ " & Worksheets("index").Range("F7")
End With

Dim a$, b&, c&
Dim Secteur As String
Secteur = Sheets("index").Range("K2")

w = 4
Do While Cells(w, 8)
If Cells(w, 8) <> Secteur Then
Rows(w).Delete Shift:=xlUp
Else
w = w + 1
End If
Loop

MySheet1.Tab.ColorIndex = 1

' ***-------------------------------------------------------------***
Worksheets("__ 02 __").Copy After:=Sheets(Worksheets.Count)
Set MySheet2 = ActiveSheet
With MySheet2
   .Name = "02_ " & Worksheets("index").Range("F7")
End With

Dim d$, e&, f&

x = 4
Do While Cells(x, 8)
If Cells(x, 8) <> Secteur Then
Rows(x).Delete Shift:=xlUp
Else
x = x + 1
End If
Loop

MySheet2.Tab.ColorIndex = 1

' ***-------------------------------------------------------------***
Worksheets("__ 03 __").Copy After:=Sheets(Worksheets.Count)
Set MySheet3 = ActiveSheet
With MySheet3
   .Name = "03_ " & Worksheets("index").Range("F7")
End With

y = 4
Do While Cells(y, 8)
If Cells(y, 8) <> Secteur Then
Rows(y).Delete Shift:=xlUp
Else
y = y + 1
End If
Loop

MySheet3.Tab.ColorIndex = 1

' ***-------------------------------------------------------------***
Worksheets("__ 04 __").Copy After:=Sheets(Worksheets.Count)
Set MySheet4 = ActiveSheet
With MySheet4
   .Name = "04_ " & Worksheets("index").Range("F7")
End With

z = 4
Do While Cells(z, 8)
If Cells(z, 8) <> Secteur Then
Rows(z).Delete Shift:=xlUp
Else
z = z + 1
End If
Loop

MySheet4.Tab.ColorIndex = 1