La macro du module ne s'exécute pas avec celle de la feuille

Version imprimable

11/09/2009, 11h31
Neptune64

La macro du module ne s'exécute pas avec celle de la feuille

Bonjour le forum,

Quelqu'un pourrait-il m'aider, ci-dessous j'ai 2 macros, la première dans un module et la seconde dans une feuille.
Quand je lance la macro "compare", ça prend un peu de temps avant de démarer, mais ça marche. Mais quand j'ajoute la macro dans la feuille et que je lance le "compare", le document reste bloquer !! possible qu'il s'exécuterais mais cela prend beaucoup trop de temps !!
Et jai besoin des 2 !!

merci de votre aide

Option Explicit

Public bArret As Boolean

Public Sub Compare()
Dim I, col, c, d, e, f As Integer
Dim P, NbNewData, NbDataControle As Long
Dim ValeurCherchee, NomUser As String
Dim ValeurCellule, Retour, PlageCopie, Plage As Range
Dim NbNewCase, NbLigneDecompte, NbLigneArchive, NbNouveauxCas, NbCasTraite As Long
Dim NbAvecSucces, Nbjour7, NumLigneDansNC As Long
Dim Tableau() As String

NbNewData = Sheets("New Data").Cells(65536, 1).End(xlUp).Row
NbDataControle = Sheets("Data controle").Cells(65536, 1).End(xlUp).Row
NbLigneDecompte = Sheets("Decompte").Cells(65536, 1).End(xlUp).Row
NbLigneArchive = Sheets("Archive").Cells(65536, 1).End(xlUp).Row
NbNewCase = Sheets("New Case").Cells(65536, 1).End(xlUp).Row

'Initialisation
NbNouveauxCas = 0: NbCasTraite = 0: NbNewCase = 0:
Nbjour7 = 0

'Efface le contenu de la feuille New Case avant le nouveau transfert
With Sheets("New Case")
If .[A4] <> "" Then
.Range("A4:K" & .Cells(65536, 1).End(xlUp).Row).ClearContents
End If
End With

'Derniere ligne vide dans la feuille New Case
NumLigneDansNC = 4

'----PHASE 1 regarde si nouvelle valeur----
For Each ValeurCellule In Sheets("New Data").Range("A4:A" & NbNewData)
I = ValeurCellule.Row
ValeurCherchee = ValeurCellule.Value
Set Retour = Sheets("Data controle").Range("A4:A" & NbDataControle).Find(ValeurCherchee)

'Si "Retour" est différent de nothing c'est que la valeurcherchee est trouvée donc existe déjà
'on ne fait rien
'on met à jour le nb de jours dans la feuille Data Controle
If Not Retour Is Nothing Then
Sheets("Data controle").Cells(Retour.Row, 2) = Sheets("New Data").Cells(I, 2)
Sheets("Data controle").Cells(Retour.Row, 3) = Sheets("New Data").Cells(I, 3)
Sheets("Data controle").Cells(Retour.Row, 4) = Sheets("New Data").Cells(I, 4)
Sheets("Data controle").Cells(Retour.Row, 5) = Sheets("New Data").Cells(I, 5)

'Sinon "Retour" = nothing c'est que nous avons une nouvelle valeur à insérer
'Si autre type de ligne = transfert vers feuilles
Else
'----TRANSFERT VERS DATA CONTROLE----
For col = 1 To 10
'Arrete la procèdure Worksheet_Change de la feuille Data Controle
bArret = True
Sheets("Data controle").Cells(NbDataControle + 1, col) = Sheets("New Data").Cells(I, col)
Next col

NbNouveauxCas = NbNouveauxCas + 1
'Ajoute une nouvelle valeur insérée dans Data Controle
NbDataControle = NbDataControle + 1

'----TRANSFERT VERS NEW CASE----
For col = 1 To 10
Sheets("New Case").Cells(NumLigneDansNC, 1) = Format(Date, "dd.mm.yyyy ") & Format(Time, "hh") & " h " & Format(Time, "mm")
Sheets("New Case").Cells(NumLigneDansNC, col + 1) = Sheets("New Data").Cells(I, col)
Next col
'Incrémente la ligne d'après
NumLigneDansNC = NumLigneDansNC + 1
End If

Next ValeurCellule

'Suppression des lignes contenues dans la variable Tableau
'avant la phase 2
On Error Resume Next
For I = UBound(Tableau) To 0 Step -1
Sheets("New Data").Cells(Tableau(I), 1).EntireRow.Delete
Next I

'Efface la variable tableau de la mémoire
Erase Tableau

'----PHASE 2 Mise à jour de la liste dans Data Controle----
For Each ValeurCellule In Sheets("Data controle").Range("A4:A" & NbDataControle)
I = ValeurCellule.Row
ValeurCherchee = ValeurCellule.Value
Set Retour = Sheets("New Data").Range("A4:A" & NbNewData).Find(ValeurCherchee)

'Si une valeur dans la variable "Retour" c'est qu'elle existe dans la feuille New Data
'Donc pas de suppression
If Not Retour Is Nothing Then
Else
'Inscription de la date du jour dans l'archive
Sheets("Archive").Cells(NbLigneArchive + 1, 1) = Date
'Recopie des doublons dans l'archive
Set PlageCopie = Sheets("Data controle").Range(Cells(I, 1), Cells(I, 17))
PlageCopie.Copy
Sheets("Archive").Range("b" & NbLigneArchive + 1).PasteSpecial
NbLigneArchive = NbLigneArchive + 1
NbCasTraite = NbCasTraite + 1

'Mémorisation des lignes à supprimer
ReDim Preserve Tableau(NbCasTraite - 1)
Tableau(NbCasTraite - 1) = I
End If
Next ValeurCellule

'Suppression des lignes contenues dans la variable Tableau
On Error Resume Next
For I = UBound(Tableau) To 0 Step -1
Sheets("Data controle").Cells(Tableau(I), 1).EntireRow.Delete
Next I

'Efface la variable tableau de la mémoire
Erase Tableau

'Inscription dans la feuille Decompte
Sheets("Decompte").Cells(NbLigneDecompte + 1, 1) = Application.UserName 'NomUser
Sheets("Decompte").Cells(NbLigneDecompte + 1, 2) = Format(Date, "dd.mm.yyyy ") & Format(Time, "hh") & " h " & Format(Time, "mm")
Sheets("Decompte").Cells(NbLigneDecompte + 1, 5) = NbNouveauxCas
Sheets("Decompte").Cells(NbLigneDecompte + 1, 6) = NbCasTraite
'Fin d'arrêt du blocage de la procèdure
bArret = False

End Sub

Macro sous la feuille !!

Private Sub Worksheet_Change(ByVal Target As Range)

' met de la couleur si la cellule déroulante a changée de valeur

Dim I As Integer 'ligne
Dim Nbmaxlignes As Integer

Dim celltocolor As String ' pour stocker le range à colorier
Dim celltocolor2 As String

Dim celltest As String ' pour test si changement dans cellule
Dim valcol As String

Nbmaxlignes = 1000 'indiquer une ligne de plus que la colonne où il y a le dernier texte

I = 1

Do While I < Nbmaxlignes

valcol = "K"

celltest = valcol & I

celltocolor = "B" & I & ":C" & I
celltocolor2 = "K" & I & ":K" & I

' Range(celltest).Font.Color = RGB(206, 16, 57)
' Range(celltocolor).Interior.ColorIndex = 6

If Range(celltest) = "" Then
Range(celltocolor).Interior.Color = RGB(255, 255, 255)
Range(celltocolor2).Interior.Color = RGB(255, 255, 255)
Else
End If
'
If Range(celltest) = "Not installed" Then 'Orange 1
Range(celltocolor).Interior.Color = RGB(255, 165, 0)
Range(celltocolor2).Interior.Color = RGB(255, 165, 0)
Else
End If
'
If Range(celltest) = "Wait answer client" Then 'Pink 2
Range(celltocolor).Interior.Color = RGB(255, 105, 180)
Range(celltocolor2).Interior.Color = RGB(255, 105, 180)
Else
End If
'
If Range(celltest) = "Task open" Then 'bleu 3
Range(celltocolor).Interior.Color = RGB(135, 206, 250)
Range(celltocolor2).Interior.Color = RGB(135, 206, 250)
Else
End If
'
If Range(celltest) = "Reminder" Then 'Gris 4
Range(celltocolor).Interior.Color = RGB(190, 190, 190)
Range(celltocolor2).Interior.Color = RGB(190, 190, 190)
Else
End If
'
If Range(celltest) = "Devices ?" Then 'jaune clair 5
Range(celltocolor).Interior.Color = RGB(255, 255, 0)
Range(celltocolor2).Interior.Color = RGB(255, 255, 0)
Else
End If
'
If Range(celltest) = "Bloked finance" Then 'violet 6
Range(celltocolor).Interior.Color = RGB(186, 85, 211)
Range(celltocolor2).Interior.Color = RGB(186, 85, 211)
Else
End If
'
If Range(celltest) = "RMA devices" Then 'Pink foncé 7
Range(celltocolor).Interior.Color = RGB(255, 0, 255)
Range(celltocolor2).Interior.Color = RGB(255, 0, 255)
Else
End If
'
If Range(celltest) = "Connected" Then 'vert clair 8
Range(celltocolor).Interior.Color = RGB(0, 255, 0)
Range(celltocolor2).Interior.Color = RGB(0, 255, 0)
Else
End If
'

I = I + 1

Loop

End Sub
11/09/2009, 11h36
Gotita

Salut bon je ne vais pas répondre à ton problème mais juste au lieu de mettre plein de "If Range(celltest) = " un select case ne serait pas mieux d'un point de vue travail du pocesseur,visibilité du code et rapidité?

Cordialement
11/09/2009, 15h28
Fvandermeulen
Salut Neptune64 et les autres,

Ca ma l'air bien fouilli ton truc (d'ailleurs les prochaine fois utilise les balises pour ton code, sélectionne le code dans le messager et click sur #)

Sauf erreur de ma part, le selection_change ne fonctionne que si le changement est fait "à la main" sur la feuille.

De plus tu semble repasser sur toutes les lignes, hors l'avantage de cette méthode est d'avoir l'adresse de la cellule modifiée grâce au Target.
Au vu de ce que tu fais tu n'as pas besoin de le mettre dans un module de feuille...

Bonne continuation.

A+

Edit: Encore un truc que je viens de voir (entre autre)...
Code:

1 2 3 4 5 I = 1 Do While I < Nbmaxlignes ... I = I + 1 Loop
Peut se faire par
Code:

1 2 3 For i = 1 to NbMaxlignes ... Next i
Un peu plus court

Salut Fvandermeulen et Gitita
Merci pour ces infos ok pour le code je ne savais pas !!

j'ai simplifié le code de la feuille, je pense que c'est mieux comme ça :-)

le code ci-dessous est dans la feuille parce que selon le mot que je change dans ma feuille je dois changer la couleur dans certaines cellules. Mais il y a peut-être une autre possibilité, je ne connais pas !!

Ce que je ne comprend pas c'est que quand je n'ai pas ce code dans la feuille, ma macro prend 10 x moins de temps pour s'exécuter ?

A part le problème de temps ça fonctionne très bien !!

Je remet l'autre code à la fin

Merci :-)))))

Code de feuille pour changement de couleur selon sélection

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
25
26
27
28
29
30
31
32
33
34
Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim i As Integer 'ligne
 
For i = Cells(4, 11).CurrentRegion.Rows.Count To 1 Step -1
If Cells(i, 11).Value = "" Then Cells(i, 11).Interior.Color = RGB(255, 255, 255)
If Cells(i, 11).Value = "" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 255, 255)
 
If Cells(i, 11).Value = "Not installed" Then Cells(i, 11).Interior.Color = RGB(255, 165, 0) 'Orange 1
If Cells(i, 11).Value = "Not installed" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 165, 0) 'Orange 1
 
If Cells(i, 11).Value = "Wait answer client" Then Cells(i, 11).Interior.Color = RGB(255, 105, 180) 'Pink 2
If Cells(i, 11).Value = "Wait answer client" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 105, 180) 'Pink 2
 
If Cells(i, 11).Value = "Task open" Then Cells(i, 11).Interior.Color = RGB(135, 206, 250) 'bleu 2
If Cells(i, 11).Value = "Task open" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(135, 206, 250) 'bleu 2
 
If Cells(i, 11).Value = "Reminder" Then Cells(i, 11).Interior.Color = RGB(190, 190, 190) 'gris 4
If Cells(i, 11).Value = "Reminder" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(190, 190, 190) 'gris 4
 
If Cells(i, 11).Value = "Devices ?" Then Cells(i, 11).Interior.Color = RGB(255, 255, 0) 'jaune clair 5
If Cells(i, 11).Value = "Devices ?" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 255, 0) 'jaune clair 5
 
If Cells(i, 11).Value = "Bloked finance" Then Cells(i, 11).Interior.Color = RGB(186, 85, 211) 'violet 6
If Cells(i, 11).Value = "Bloked finance" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(186, 85, 211) 'violet 6
 
If Cells(i, 11).Value = "RMA devices" Then Cells(i, 11).Interior.Color = RGB(255, 0, 255) 'Pink foncé 7
If Cells(i, 11).Value = "RMA devices" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 0, 255) 'Pink foncé 7
 
If Cells(i, 11).Value = "Connected" Then Cells(i, 11).Interior.Color = RGB(0, 255, 0) 'vert clair 8
If Cells(i, 11).Value = "Connected" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(0, 255, 0) 'vert clair 8
Next i
 
End

macro qui check les modifications entre 2 feuilles et déplace les données

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
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
Public bArret As Boolean
 
Public Sub Compare()
    Dim i, col, c, d, e, f As Integer
    Dim P, NbNewData, NbDataControle As Long
    Dim ValeurCherchee, NomUser As String
    Dim ValeurCellule, Retour, PlageCopie, Plage As Range
    Dim NbNewCase, NbLigneDecompte, NbLigneArchive, NbNouveauxCas, NbCasTraite As Long
    Dim NbAvecSucces, Nbjour7, NumLigneDansNC As Long
    Dim Tableau() As String
 
NbNewData = Sheets("New Data").Cells(65536, 1).End(xlUp).Row
NbDataControle = Sheets("Data controle").Cells(65536, 1).End(xlUp).Row
NbLigneDecompte = Sheets("Decompte").Cells(65536, 1).End(xlUp).Row
NbLigneArchive = Sheets("Archive").Cells(65536, 1).End(xlUp).Row
NbNewCase = Sheets("New Case").Cells(65536, 1).End(xlUp).Row
 
 
'Initialisation
NbNouveauxCas = 0: NbCasTraite = 0: NbNewCase = 0:
Nbjour7 = 0
 
'Efface le contenu de la feuille New Case avant le nouveau transfert
With Sheets("New Case")
    If .[A4] <> "" Then
        .Range("A4:K" & .Cells(65536, 1).End(xlUp).Row).ClearContents
    End If
End With
 
'Derniere ligne vide dans la feuille New Case
NumLigneDansNC = 4
 
 
'----PHASE 1 regarde si nouvelle valeur----
For Each ValeurCellule In Sheets("New Data").Range("A4:A" & NbNewData)
    i = ValeurCellule.Row
    ValeurCherchee = ValeurCellule.Value
    Set Retour = Sheets("Data controle").Range("A4:A" & NbDataControle).Find(ValeurCherchee)
 
    'Si "Retour" est différent de nothing c'est que la valeurcherchee est trouvée donc existe déjà
    'on ne fait rien
    'on met à jour le nb de jours dans la feuille Data Controle
    If Not Retour Is Nothing Then
        Sheets("Data controle").Cells(Retour.Row, 2) = Sheets("New Data").Cells(i, 2)
        Sheets("Data controle").Cells(Retour.Row, 3) = Sheets("New Data").Cells(i, 3)
        Sheets("Data controle").Cells(Retour.Row, 4) = Sheets("New Data").Cells(i, 4)
        Sheets("Data controle").Cells(Retour.Row, 5) = Sheets("New Data").Cells(i, 5)
 
    'Sinon "Retour" = nothing c'est que nous avons une nouvelle valeur à insérer
    'Si autre type de ligne = transfert vers feuilles
    Else
        '----TRANSFERT VERS DATA CONTROLE----
        For col = 1 To 10
            'Arrete la procèdure Worksheet_Change de la feuille Data Controle
            bArret = True
            Sheets("Data controle").Cells(NbDataControle + 1, col) = Sheets("New Data").Cells(i, col)
        Next col
 
        NbNouveauxCas = NbNouveauxCas + 1
        'Ajoute une nouvelle valeur insérée dans Data Controle
        NbDataControle = NbDataControle + 1
 
        '----TRANSFERT VERS NEW CASE----
        For col = 1 To 10
            Sheets("New Case").Cells(NumLigneDansNC, 1) = Format(Date, "dd.mm.yyyy ") & Format(Time, "hh") & " h " & Format(Time, "mm")
            Sheets("New Case").Cells(NumLigneDansNC, col + 1) = Sheets("New Data").Cells(i, col)
        Next col
        'Incrémente la ligne d'après
        NumLigneDansNC = NumLigneDansNC + 1
     End If
 
Next ValeurCellule
 
'Suppression des lignes contenues dans la variable Tableau
'avant la phase 2
On Error Resume Next
For i = UBound(Tableau) To 0 Step -1
    Sheets("New Data").Cells(Tableau(i), 1).EntireRow.Delete
Next i
 
'Efface la variable tableau de la mémoire
Erase Tableau
 
'----PHASE 2 Mise à jour de la liste dans Data Controle----
For Each ValeurCellule In Sheets("Data controle").Range("A4:A" & NbDataControle)
    i = ValeurCellule.Row
    ValeurCherchee = ValeurCellule.Value
    Set Retour = Sheets("New Data").Range("A4:A" & NbNewData).Find(ValeurCherchee)
 
    'Si une valeur dans la variable "Retour" c'est qu'elle existe dans la feuille New Data
    'Donc pas de suppression
    If Not Retour Is Nothing Then
    Else
        'Inscription de la date du jour dans l'archive
        Sheets("Archive").Cells(NbLigneArchive + 1, 1) = Date
        'Recopie des doublons dans l'archive
        Set PlageCopie = Sheets("Data controle").Range(Cells(i, 1), Cells(i, 17))
        PlageCopie.Copy
        Sheets("Archive").Range("b" & NbLigneArchive + 1).PasteSpecial
        NbLigneArchive = NbLigneArchive + 1
        NbCasTraite = NbCasTraite + 1
 
        'Mémorisation des lignes à supprimer
        ReDim Preserve Tableau(NbCasTraite - 1)
        Tableau(NbCasTraite - 1) = i
    End If
Next ValeurCellule
 
'Suppression des lignes contenues dans la variable Tableau
On Error Resume Next
For i = UBound(Tableau) To 0 Step -1
    Sheets("Data controle").Cells(Tableau(i), 1).EntireRow.Delete
Next i
 
'Efface la variable tableau de la mémoire
Erase Tableau
 
'Inscription dans la feuille Decompte
Sheets("Decompte").Cells(NbLigneDecompte + 1, 1) = Application.UserName 'NomUser
Sheets("Decompte").Cells(NbLigneDecompte + 1, 2) = Format(Date, "dd.mm.yyyy ") & Format(Time, "hh") & " h " & Format(Time, "mm")
Sheets("Decompte").Cells(NbLigneDecompte + 1, 5) = NbNouveauxCas
Sheets("Decompte").Cells(NbLigneDecompte + 1, 6) = NbCasTraite
'Fin d'arrêt du blocage de la procèdure
bArret = False
 
End Sub

14/09/2009, 08h58
Fvandermeulen
Re,
Je reviens sur mon "sauf erreur de ma part" qui est, en fait, une erreur :aie:
L'évènement Change est bien activé si un modif est initiée par un autre module.
Donc dans ton cas, le module de feuille est activé à chaque fois que ton autre macro fait un changement !

Tu peux contourner ça avec EnableEvents à placer au début de ton code (et à la fin pour réactiver), par contre ton module de feuille ne se déclenche pas du tout, si tu veux qu'il se déclenche en fin de macro 'Compar' ajoute une modif après la réactivation.
Code:

1 2 3 4 5 6 7 Public Sub Compare() Application.EnableEvents = False '... Application.EnableEvents = True End Sub
Un autre point pour "gagner" des lignes et du temps dans ton module de feuille, pas la peine de tester deux fois la même cellule, les lignes:
Code:

1 2 If Cells(i, 11).Value = "" Then Cells(i, 11).Interior.Color = RGB(255, 255, 255) If Cells(i, 11).Value = "" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 255, 255)
Fonctionnent aussi comme ça:

Code:

If Cells(i, 11).Value = "" Then Application.Union(Cells(i, 2), Cells(i, 3), Cells(i, 11)).Interior.Color = RGB(255, 255, 255)

ou

Code:

If Cells(i, 11).Value = "" Then Range("B" & i & ":C" & i & ",K" & i).Interior.Color = RGB(255, 255, 255)

Il y a surement d'autres améliorations possibles mais à toi de voir ;)

Bonne continuation.

Hello Fvandermeulen

:ccool: merci ça marche super bien.

j'ose encore te poser une question ?

En fait la macro ci-dessous me recherche sur un feuille d'environ 5000 lignes le therme "avec succès" plus dans une colonne il y a des nombres de jours de 0 à ....... jours. Alors je compte le nombre de ligne à chaque fois et ensuite je delete toutes les lignes qui ont le "avec succès plus toutes les lignes qui ont moins de 7 jours.

ça marche très bien mais ma question est y a t'il quelque chose de plus rapide ?

et 2ème si non je sais qu'il possible de faire un pop up avec le temps de traitement qui défile. Mais j'en ai aucune idée comment le faire !! es-ce qu c'est facile à faire ?

Merci :lol:

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
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
Sub conversion()
 
    Dim i%, col%, c%, d%, e%, f As Integer
    Dim P&, NbNewData&, NbDataControle As Long
    Dim ValeurCherchee$, NomUser As String
    Dim ValeurCellule, Retour, PlageCopie, Plage As Range
    Dim NbErreurs, NbQuelqueEr, NbNewCase, NbLigneDecompte, NbLigneArchive, NbNouveauxCas, NbCasTraite As Long
    Dim NbAvecSucces, Nbjour7, NumLigneDansNC As Long
    Dim Tableau() As String
 
 
 
NbNewData = Sheets("New Data").Cells(65536, 1).End(xlUp).Row
NbDataControle = Sheets("Data controle").Cells(65536, 1).End(xlUp).Row
NbLigneDecompte = Sheets("Decompte").Cells(65536, 1).End(xlUp).Row
NbLigneArchive = Sheets("Archive").Cells(65536, 1).End(xlUp).Row
NbNewCase = Sheets("New Case").Cells(65536, 1).End(xlUp).Row
 
'Initialisation
NbNouveauxCas = 0: NbCasTraite = 0: NbErreurs = 0: NbQuelqueEr = 0: NbNewCase = 0:
Nbjour7 = 0: NbAvecSucces = 0
 
'Efface le contenu de la feuille New Case avant le nouveau transfert
With Sheets("New Case")
    If .[A4] <> "" Then
        .Range("A4:K" & .Cells(65536, 1).End(xlUp).Row).ClearContents
    End If
End With
 
'Derniere ligne vide dans la feuille New Case
NumLigneDansNC = 4
 
'Compte le nombre de lignes total
c = Sheets("New Data").Range("I4:I" & Range("I4").End(xlDown).Row).Count
Sheets("Decompte").Cells(NbLigneDecompte + 1, 3) = c
 
 
Set Plage = Range("I4:I" & Range("I4").End(xlDown).Row)
For P = Plage.Cells.Count To 1 Step -1
  If Plage.Cells(P).Value = "Avec succès" Then
    Plage.Cells(P).EntireRow.Delete
  End If
Next
 
'd = Sheets("New Data").Range("I4:I" & Range("I4").End(xlDown).Row).Count
'Sheets("Decompte").Cells(NbLigneDecompte + 1, 11) = d
 
 
Set Plage = Range("G4:G" & Range("G4").End(xlDown).Row)
For P = Plage.Cells.Count To 1 Step -1
  If Plage.Cells(P).Value < 7 Then
    Plage.Cells(P).EntireRow.Delete
  End If
Next
 
e = Sheets("New Data").Range("I4:I" & Range("I4").End(xlDown).Row).Count
Sheets("Decompte").Cells(NbLigneDecompte + 1, 4) = e
 
Range("A1").Select
Sheets("Data controle").Select
 
End Sub

Re,
Pour commencer avec For To, il n'est pas nécessaire d'utiliser une plage, tu peux faire:
Code:

1 2 3 For P = cells(columns(9).cells.count,9).end(xlup).row To 4 Step -1 'pour la colonne I If Cells(P,9).Value = "Avec succès" Then rows(9).Delete Next P
Du coup on peut imaginer contrôler les 2 arguments en une fois (Attention j'ai pas testé !!)
Code:

1 2 3 For P = cells(columns(9).cells.count,9).end(xlup).row To 4 Step -1 'Boucle sur les lignes sur base de la col I de la dernière remplie à la 4ème If Cells(P, 9).Value = "Avec succès" Or Cells(P, 7).Value < 7 Then Rows(P).Delete Next P
Comme je sais pas si ça va rendre ta macro beaucoup plus rapide, regarde le fichier joint, je l'avais fait comme exemple pour un copain, si tu as des questions par rapport à ça je te conseille de refaire un autre Post.

A+

Edit: Ajout de la pièce jointe oubliée 8O

14/09/2009, 17h42
Neptune64

Hello !
Je te remercie pour ton aide précieuse et je vais tester la barre d'avancement !
:ccool: