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