Lenteur d'exécution de codes.

Version imprimable

Bonjour,
j'ai créé ces codes pour extraire des valeurs d'une liste et les coller dans d'autres feuilles selon des critères, puis supprimer les lignes selon les dates les plus anciennes et effectuer un classement avec la fonction RANK.
Les codes fonctionnent mais l’exécution est lente, environs 2 minutes.
La feuilles de données contient 500 lignes environ.

Merci pour une piste

Cordialement

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
127
128
129
130
131
132
133
134
135
136
137
138
139
Sub Traitements()
Dim i As Integer, j As Byte, f As Worksheet, x As Integer, w As Integer
Set f = Sheets("HISTO")
Application.ScreenUpdating = False
'efface les valeurs des feuilles
Sheets("Gard1").Range("A2:K5000").Clear
Sheets("Gard2").Range("A2:K5000").Clear
Sheets("Gard3").Range("A2:K5000").Clear
Sheets("Gard4").Range("A2:K5000").Clear
Sheets("histo").Select
With Sheets("HISTO")
For i = 2 To f.Range("A" & Rows.Count).End(xlUp).Row
    Set f = Sheets("HISTO")
    'copie les valeurs selon conditions "MEDecin",INTerne sur la feuille Garde1
    If f.Range("A" & i) = "MED" Or Range("A" & i) = "INT1" Or Range("A" & i) = "INT2" Or Range("A" & i) = "INT3" Then
        f.Range("A" & i & ":i" & i).Copy Sheets("Gard1").Range("A" & Sheets("Gard1").Range("A" & Rows.Count).End(xlUp).Row + 1)
 
 
    Else
        'copie les valeurs selon conditions "INFirmier" sur la feuille Garde2
        If f.Range("A" & i) = "INF1" Or Range("A" & i) = "INF2" Then
            f.Range("A" & i & ":i" & i).Copy Sheets("Gard2").Range("A" & Sheets("Gard2").Range("A" & Rows.Count).End(xlUp).Row + 1)
        Else
        'copie les valeurs selon conditions "AideSoignant", sur la feuille Garde3 et Garde4
            If f.Range("A" & i) = "AS1" Or Range("A" & i) = "AS2" Then
                f.Range("A" & i & ":i" & i).Copy Sheets("Gard3").Range("A" & Sheets("Gard3").Range("A" & Rows.Count).End(xlUp).Row + 1)
                f.Range("A" & i & ":i" & i).Copy Sheets("Gard4").Range("A" & Sheets("Gard4").Range("A" & Rows.Count).End(xlUp).Row + 1)
            Else
                'copie les valeurs selon conditions "AgentHosp" sur la feuille Garde4
                If f.Range("A" & i) = "ASH1" Or Range("A" & i) = "ASH2" Then
                    f.Range("A" & i & ":i" & i).Copy Sheets("Gard4").Range("A" & Sheets("Gard4").Range("A" & Rows.Count).End(xlUp).Row + 1)
                End If
            End If
        End If
    End If
    Next i
 
   End With
 
 
SupDateINF
End Sub
 
 
Sub SupDateINF()
  Sheets("Gard1").Select
'supprime la ligne selon la date plus ancienne d'une personne de la colonne E en fonction du nom_prenom colonne I
Dim i As Long, j As Long, dercell As Long, valcell As String
    With Sheets("Gard1")
For i = Cells(Rows.Count, 9).End(xlUp).Row To 2 Step -1
For j = Cells(Rows.Count, 9).End(xlUp).Row To 2 Step -1
If Cells(j, 9) = Cells(i, 9) Then 'compare le nom
If Cells(j, 5) < Cells(i, 5) Then 'compare la date
Cells(j, 1).EntireRow.Delete
End If: End If
Next j: Next i
 
   Sheets("Gard1").Select
   'écrit les formules dans les colonne J et K
    dercell = Range("a65000").End(xlUp).Row
    valcell = Range("a65000").End(xlUp).Address
    Range("J2" & ":" & "J" & dercell).FormulaR1C1 = "=RANK.EQ(RC[1],C[1])" 'formule RANG dans la colonne J
    Range("K2" & ":" & "K" & dercell) = "=IF(RC[-6]="""",TODAY()-RC[-4],TODAY()-RC[-6])" 'formule écart aujourdhui - date colonne E ou G si E est vide
    [J:J].Value = [J:J].Value 'copie valeur uniquement
    [K:K].Value = [K:K].Value 'copie valeur uniquement
    Range("J2:J5000").NumberFormat = "0" 'format numérique colonne J
    Range("G2" & ":" & "G" & dercell).NumberFormat = "m/d/yyyy"
Columns("A:K").Sort key1:=Range("J2"), Header:=xlYes 'tri ascendant colonne J
End With
 
 With Sheets("Gard2")
 'idem Gard1
For i = Cells(Rows.Count, 9).End(xlUp).Row To 2 Step -1
For j = Cells(Rows.Count, 9).End(xlUp).Row To 2 Step -1
If Cells(j, 9) = Cells(i, 9) Then 'compare le nom
If Cells(j, 5) < Cells(i, 5) Then 'compare la date
Cells(j, 1).EntireRow.Delete
End If: End If
Next j: Next i
Sheets("Gard2").Select
 
    dercell = Range("a65000").End(xlUp).Row
    valcell = Range("a65000").End(xlUp).Address
    Range("J2" & ":" & "J" & dercell).FormulaR1C1 = "=RANK.EQ(RC[1],C[1])"
 
    Range("K2" & ":" & "K" & dercell) = "=IF(RC[-6]="""",TODAY()-RC[-4],TODAY()-RC[-6])"
    [J:J].Value = [J:J].Value
    [K:K].Value = [K:K].Value
    Range("J2:J5000").NumberFormat = "0"
    Range("G2" & ":" & "G" & dercell).NumberFormat = "m/d/yyyy"
Columns("A:K").Sort key1:=Range("J2"), Header:=xlYes
End With
 
 With Sheets("Gard3")
 'idem Gard1
For i = Cells(Rows.Count, 9).End(xlUp).Row To 2 Step -1
For j = Cells(Rows.Count, 9).End(xlUp).Row To 2 Step -1
If Cells(j, 9) = Cells(i, 9) Then 'compare le nom
If Cells(j, 5) < Cells(i, 5) Then 'compare la date
Cells(j, 1).EntireRow.Delete
End If: End If
Next j: Next i
Sheets("Gard3").Select
 
    dercell = Range("a65000").End(xlUp).Row
    valcell = Range("a65000").End(xlUp).Address
    Range("J2" & ":" & "J" & dercell).FormulaR1C1 = "=RANK.EQ(RC[1],C[1])"
 
    Range("K2" & ":" & "K" & dercell) = "=IF(RC[-6]="""",TODAY()-RC[-4],TODAY()-RC[-6])"
    [J:J].Value = [J:J].Value
    [K:K].Value = [K:K].Value
    Range("J2:J5000").NumberFormat = "0"
    Range("G2" & ":" & "G" & dercell).NumberFormat = "m/d/yyyy"
Columns("A:K").Sort key1:=Range("J2"), Header:=xlYes
End With
 
 With Sheets("Gard4")
 'idem Gard1
For i = Cells(Rows.Count, 9).End(xlUp).Row To 2 Step -1
For j = Cells(Rows.Count, 9).End(xlUp).Row To 2 Step -1
If Cells(j, 9) = Cells(i, 9) Then 'compare le nom
If Cells(j, 5) < Cells(i, 5) Then 'compare la date
Cells(j, 1).EntireRow.Delete
End If: End If
Next j: Next i
Sheets("Gard4").Select
 
    dercell = Range("a65000").End(xlUp).Row
    valcell = Range("a65000").End(xlUp).Address
    Range("J2" & ":" & "J" & dercell).FormulaR1C1 = "=RANK.EQ(RC[1],C[1])"
 
    Range("K2" & ":" & "K" & dercell) = "=IF(RC[-6]="""",TODAY()-RC[-4],TODAY()-RC[-6])"
    [J:J].Value = [J:J].Value
    [K:K].Value = [K:K].Value
    Range("J2:J5000").NumberFormat = "0"
    Range("G2" & ":" & "G" & dercell).NumberFormat = "m/d/yyyy"
Columns("A:K").Sort key1:=Range("J2"), Header:=xlYes
End With
End Sub

Bonjour,

Voici le code nettoyé. Si vous faites un With feuille, vous n'avez plus besoin de faire un Select feuille, mais il faut bien mettre les .Range et .Cells pour indiquer qu'ils sont de la feuille. Si vous utilisez Select feuille, alors aucun . devant Range et Cells. Surtout ne pas se mélanger les pinceaux!

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
Option Explicit
 
Sub Traitements()
    Dim i As Integer, j As Byte, f As Worksheet, x As Integer, w As Integer
    Dim t As Single
    Set f = Sheets("HISTO")
    t = Timer
    Application.ScreenUpdating = False
    'efface les valeurs des feuilles
    Sheets("Gard1").Range("A2:K5000").Clear
    Sheets("Gard2").Range("A2:K5000").Clear
    Sheets("Gard3").Range("A2:K5000").Clear
    Sheets("Gard4").Range("A2:K5000").Clear
    With f
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
            'copie les valeurs selon conditions "MEDecin",INTerne sur la feuille Garde1
            Select Case .Range("A" & i).Value
                Case "MED", "INT1", "INT2", "INT3"
                    .Range("A" & i & ":I" & i).Copy Sheets("Gard1").Range("A" & Sheets("Gard1").Range("A" & Rows.Count).End(xlUp).Row + 1)
                Case "INF1", "INF2"
                    .Range("A" & i & ":I" & i).Copy Sheets("Gard2").Range("A" & Sheets("Gard2").Range("A" & Rows.Count).End(xlUp).Row + 1)
                Case "AS1", "AS2"
                    .Range("A" & i & ":I" & i).Copy Sheets("Gard3").Range("A" & Sheets("Gard3").Range("A" & Rows.Count).End(xlUp).Row + 1)
' vraiment ?        .Range("A" & i & ":I" & i).Copy Sheets("Gard4").Range("A" & Sheets("Gard4").Range("A" & Rows.Count).End(xlUp).Row + 1)
                Case "ASH1", "ASH2"
                    .Range("A" & i & ":I" & i).Copy Sheets("Gard4").Range("A" & Sheets("Gard4").Range("A" & Rows.Count).End(xlUp).Row + 1)
                Case Else
                    MsgBox "Cas non traité. [A" & i & "]=" & .Range("A" & i).Value, , "Pour info"
            End Select
        Next i
    End With
    Debug.Print "Traitement", t - Timer: t = Timer
    SupDateINF "Gard1"
    Debug.Print "Gard1", t - Timer: t = Timer
    SupDateINF "Gard2"
    Debug.Print "Gard2", t - Timer: t = Timer
    SupDateINF "Gard3"
    Debug.Print "Gard3", t - Timer: t = Timer
    SupDateINF "Gard4"
    Debug.Print "Gard4", t - Timer: t = Timer
    Application.ScreenUpdating = True
End Sub
 
Private Sub SupDateINF(sNomFeuille As String)
    Dim i As Long, j As Long, derCell As Long, valCell As String
    Sheets(sNomFeuille).Select
    'supprime la ligne selon la date plus ancienne d'une personne de la colonne E en fonction du nom_prenom colonne I
    derCell = Cells(Rows.Count, 9).End(xlUp).Row
    '--- à mon avis il faudrait commencer par faire un tri par nom et par date,
    '--- et ensuite supprimer les lignes inutiles
    '--- cela pour ne parcourir que 1 seule fois la liste (pas besoin de j)
    For i = derCell To 2 Step -1                    '--- parcourt 1 fois la liste --- 100 lignes
        For j = derCell To 2 Step -1                '--- parcourt une 2e fois la liste --- 100 * 100 = 10000
            If Cells(j, 9) = Cells(i, 9) Then       'compare le nom
                If Cells(j, 5) < Cells(i, 5) Then   'compare la date
                    Cells(j, 1).EntireRow.Delete
                End If
            End If
        Next j
    Next i
   'écrit les formules dans les colonne J et K
    derCell = Range("A65000").End(xlUp).Row
    valCell = Range("A65000").End(xlUp).Address
    Range("J2:J" & derCell).FormulaR1C1 = "=RANK.EQ(RC[1],C[1])"                  'formule RANG dans la colonne J
    Range("K2:K" & derCell).FormulaR1C1 = "=IF(RC[-6]="""",TODAY()-RC[-4],TODAY()-RC[-6])"    'formule écart aujourdhui - date colonne E ou G si E est vide
    [J:J].Value = [J:J].Value                                                     'copie valeur uniquement
    [K:K].Value = [K:K].Value                                                     'copie valeur uniquement
    Range("J2:J" & derCell).NumberFormat = "0"                                    'format numérique colonne J
    Range("G2:G" & derCell).NumberFormat = "m/d/yyyy"       '--- ? vraiment ?
    Columns("A:K").Sort key1:=Range("J2"), Header:=xlYes                          'tri ascendant colonne J
End Sub

J'ai ajouté les Debug.Print pour que vous puissiez voir les temps mis (en secondes). A enlever ensuite.

A mon avis la lenteur vient de SupDateINF où vous effectuer le tri après effacement des lignes inutiles. Il faudrait commencer par le tri sur nom et date pour ensuite supprimer les lignes inutiles ...en 1 seul passage.

Cordialement.

P.S. Il serait même préférable de commencer par faire le tri dans la feuille "Histo" pour ensuite ne recopier que les lignes utiles dans les feuilles "Gard", ce qui éviterait à avoir à en effacer ensuite.

14/10/2020, 19h11
counterbob

Merci Eric

Avec vos modifications la durée est d'environ 20 secondes c'est parfait
je vais suivre vos conseils et reviens vers vous.

merci beaucoup
Cordialement