Discussion :

[bboy-eazy]

Bonjour,


Je cherche à savoir ce qui peut influencer la longueur d'exécution d'un code.

j'ai un code principale dans lequel j' intègre une fonction qui cherche la date minimum différente de 0 car il est possible qu'il n'y ai pas de date

si j'intègre le code directement dans le code principale, la vitesse est beaucoup plus rapide que si je passe par une fonction à part

dans mon exemple il s'agit dans la fonction Min_Ctrl

comment puis je optimiser la vitesse?

Merci d'avance

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
Function MIN_CTRL(L As Long) As Double
Dim DL&, k%
Dim Tbl() As Variant, c() As Variant, b#()
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Tampon")
    DL = .Cells(.Rows.Count, 2).End(xlUp).Row
    Tbl() = .Range("A1:BJ" & DL).Value2
End With
c = Array(6, 9, 12, 15, 18, 22, 29, 41, 46, 51, 56)
ReDim b(1)
For k = LBound(c) To UBound(c)
    If Tbl(L, c(k)) <> "" Then
        If b(1) = 0 Then b(1) = Tbl(L, c(k)) Else ReDim Preserve b(UBound(b) + 1): b(UBound(b)) = Tbl(L, c(k))
    End If
Next k
MIN_CTRL = Application.Min(b())
Erase Tbl
Erase c
Erase b
End Function

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
Sub Nb_RCT_Et_No_RCT(OUINON As Boolean)
Dim RG As Range
Dim a() As Variant, b() As Variant, aa() As Variant
Dim j%, k%
Dim DL&, i&, CPT_P&, CPT_A&, CPT_T&, CPT_M&, CPT_Pa&, CPT_Aa&, CPT_Ta&, CPT_Ma&
Dim Mctrl#
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Tampon")
    DL = .Cells(.Rows.Count, 2).End(xlUp).Row
    a() = .Range("A1:BJ" & DL).Value2
End With
With ThisWorkbook.Worksheets("Liste")
    Set RG = .Range("A3:A54").Find(ThisWorkbook.Worksheets("TdB").Range("O2").Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
    j = RG.Row: Set RG = Nothing
    CPT_P = 0
    CPT_T = 0
    CPT_A = 0
    CPT_M = 0
    CPT_Pa = 0
    CPT_Ta = 0
    CPT_Aa = 0
    CPT_Ma = 0
    For i = LBound(a, 1) To UBound(a, 1)
        Mctrl = MIN_CTRL(i)
        If a(i, 39) = "" Or a(i, 39) = 0 Then
            'pas de RCT
            Select Case a(i, 3)
                Case "PETRI": If Year(CDate(Mctrl)) & DatePart("ww", CDate(Mctrl), 2, 2) = .Cells(j, 1).Value Then CPT_P = CPT_P + 1
                Case "T&F": If Year(CDate(Mctrl)) & DatePart("ww", CDate(Mctrl), 2, 2) = .Cells(j, 1).Value Then CPT_T = CPT_T + 1
                Case "AUTRES": If Year(CDate(Mctrl)) & DatePart("ww", CDate(Mctrl), 2, 2) = .Cells(j, 1).Value Then CPT_A = CPT_A + 1
                Case "MS": If Year(CDate(Mctrl)) & DatePart("ww", CDate(Mctrl), 2, 2) = .Cells(j, 1).Value Then CPT_M = CPT_M + 1
            End Select
        Else
            'si RCT
            b = Array(a(i, 40), a(i, 41), a(i, 46), a(i, 51), a(i, 56))
            Select Case a(i, 3)
                Case "PETRI"
                    For k = LBound(b) To UBound(b)
                        If Year(CDate(b(k))) & DatePart("ww", CDate(b(k)), 2, 2) = .Cells(j, 1).Value Then CPT_Pa = CPT_Pa + 1
                    Next k
                Case "T&F"
                    For k = LBound(b) To UBound(b)
                        If Year(CDate(b(k))) & DatePart("ww", CDate(b(k)), 2, 2) = .Cells(j, 1).Value Then CPT_Ta = CPT_Ta + 1
                    Next k
                Case "AUTRES"
                    For k = LBound(b) To UBound(b)
                        If Year(CDate(b(k))) & DatePart("ww", CDate(b(k)), 2, 2) = .Cells(j, 1).Value Then CPT_Aa = CPT_Aa + 1
                    Next k
                Case "MS"
                    For k = LBound(b) To UBound(b)
                        If Year(CDate(b(k))) & DatePart("ww", CDate(b(k)), 2, 2) = .Cells(j, 1).Value Then CPT_Ma = CPT_Ma + 1
                    Next k
            End Select
            Erase b
        End If
    Next i
End With
With ThisWorkbook.Worksheets("TdB")
    .Range("H12:K12").Value = Array(CPT_Ta, CPT_Pa, CPT_Aa, CPT_Ma)
    .Range("H14:K14").Value = Array(CPT_T, CPT_P, CPT_A, CPT_M)
End With
If OUINON = True Then
    If MsgBox("Voulez-vous la liste des Recontrôles réalisés en semaine: " & ThisWorkbook.Worksheets("Liste").Cells(j, 1).Value, vbYesNo) = vbYes Then
        Erase a
        ReDim aa(1)
        aa(1) = "Liste des lots en Recontrôle semaine: " & ThisWorkbook.Worksheets("Liste").Cells(j, 1).Value
        With ThisWorkbook.Worksheets("Tampon")
            DL = .Cells(.Rows.Count, 2).End(xlUp).Row
            a() = .Range("A1:BJ" & DL).Value2
        End With
        For i = LBound(a, 1) To UBound(a, 1)
            b = Array(a(i, 40), a(i, 41), a(i, 46), a(i, 51), a(i, 56))
            For k = LBound(b) To UBound(b)
                If Year(CDate(b(k))) & DatePart("ww", CDate(b(k)), 2, 2) = ThisWorkbook.Worksheets("Liste").Cells(j, 1).Value Then
                    ReDim Preserve aa(UBound(aa) + 1)
                    aa(UBound(aa)) = a(i, 1) & " - " & a(i, 2) & " - " & a(i, 3)
                End If
            Next k
        Next i
        With ThisWorkbook.Worksheets("Liste RCT")
            .Visible = True
            .Range("A1:A100").ClearContents
            .Range("A1").Resize(UBound(aa)).Value = Application.Transpose(aa)
            .Activate
            .Range("A1:A100").RemoveDuplicates Columns:=1, Header:=xlYes
            .Range("A1:A100").Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        End With
        Erase aa
    End If
End If
Erase a
Application.ScreenUpdating = True
End Sub

merci d'avance pour vos réponses

[EBRAG]

Bonjour,

Perso, je ne suis pas fan de ces tests avec instructions sur la même ligne (je suis peut-être trop vieux )

La vieille école

Code :

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

1
2
3
4
5
If condition then
  que fais-je
Else
  que fais-je
Endif

même s'il n'y a qu'une chose à faire, cela laisse plus de liberté pour modifier le code (à mes yeux encore une fois)
du coup, je n'y vois pas clair, et ne saurais pas où pouvoir placer de exit for si, après un test concluant, on considère que ce n'est pas nécessaire de poursuivre la boucle....

Dommage de poursuivre toute la boucle si on a trouvé notre bonheur en première position !)

Si cela peut donner une piste

[Philippe PONS]

Salut,

Une remarque: les noms de variables qui n'ont pas de sens et les symboles de types de donnée(au lieu du type en clair) contribuent à rendre difficile le lecture du code!

Essaie de mettre ta fonction avec une portée private, et bien sur dans le même module que la proc principale.
Les redim preserve sur les tableaux, ça prend du temps, et le faire dans des boucles encore plus: c'est peut être là qu'il y a de l'optimisation à faire.
Cordialement,

[unparia]

Bonjour
A EBRAG a écrit :

Perso, je ne suis pas fan de ces tests avec instructions sur la même ligne (je suis peut-être trop vieux )

Je ne saurais trop le "plussoyer".
D'autant qu'un code ainsi écrit n'est non seulement difficile à lire, mais il n'économise rien une fois compilé.
Cette habitude d'écrire plusieurs instructions sur la même ligne est une fort mauvaise habitude.

Parlons maintenant de tes problèmes de lenteur d'exécution :
Je vois que tu parcours 4 fois la matrice b.
Tu devrais vite t'intéresser aux instructions imbriquées de Select Case ... et ne faire ce parcours qu'une seule fois.
(Je ne regarderais ta tentative sur ces bases que si présentée indentée/déployée et non avec plusieurs instructions sur la même ligne)

[joe.levrai]

Bonjour,

et en évitant les boucles, ça va pas mieux ?

j'ai pris au pied de la lettre ta description, à savoir que tes cellules contiennent des dates ou "rien" ... ce qui signifie qu'il n'y a pas de nombre 0

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
Function MIN_CTRL(Ligne As Long) As Double
Dim Plage As Range
Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets("Tampon")
        With .Range("A1:BJ" & .Cells(.Rows.Count, 2).End(xlUp).Row)
            On Error Resume Next
                Set Plage = .SpecialCells(xlCellTypeBlanks)
            On Error GoTo 0
 
            If Not Plage Is Nothing Then Plage.Value = "¤"
                MIN_CTRL = Application.Min(Application.Index(.Value2, Ligne, Array(6, 9, 12, 15, 18, 22, 29, 41, 46, 51, 56)))
            If Not Plage Is Nothing Then Plage.ClearContents
        End With
    End With
Application.ScreenUpdating = True
End Function
 
Sub toto()
MsgBox MIN_CTRL(6)
End Sub

L'idée, c'est :

- de constituer la plage des cellules vides
- de remplacer les vides par n'importe quoi
- de calculer parmi les colonnes souhaitées de la ligne passée en paramètre le minium
- de remettre les cellules vides comme auparavant


EDIT : j'avais pas vraiment regardé ta procédure principale
je vois que dois appeler en masse cette fonction, ce qui va ôter l'efficacité car à chaque fois tu vas triturer ta plage pour combler les "vides"
dans ce cas là, il serait opportun de constituer un tableau des lignes à analyser, d'envoyer ceci en tant qu'argument de la fonction
et la fonction te renvoie un Variant qui stocke le résultat de chaque ligne souhaitée

[eriiic]

Bonjour,

Pourquoi tout stocker dans un tableau pour utiliser à la fin MIN_CTRL = Application.Min(b()) ?
Tu dois perdre un temps fou avec les Redim Preserve.
Une simple ligne dans ta boucle du style :

Code :

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

If Tbl(L, c(k)) <> "" And Tbl(L, c(k)) < MIN_CTRL Then MIN_CTRL = Tbl(L, c(k))

ne va pas ?
eric

[bboy-eazy]

Bonjour à tous et merci pour l'interet que vous portez au problème

Je prends note de chacune de vos remarques qui vont m'aider à mieux coder Merci à tous.

je vais tester et essayer de modifier mon code grace à tous ces éléments et reviendrai vers vous pour vous faire un retour
C'est vrai qu'il y a des boucle inutiles finalement et y repensant bien

merci bcp