Macro avec Tableau en VBA et temps d'execution

**eric4459** · 04/02/2016, 16h53

Bonjour à tous,
J'ai un fichier avec une grande quantité de lignes (6620), chaque ligne correspond a une activité et comporte le poids relatif de l’activité, la date de début et la date de fin entre autres données.
Je cherche a distribuer le poids de chaque activité sur une échelle de temps puis faire le total pour chaque jour de mon calendrier.
Exemple :
Nom : Distribution_Poids.jpg
Affichages : 389
Taille : 45,3 Ko

Nom : Distribution_Poids.jpg
Affichages : 389
Taille : 45,3 Ko

J'ai donc crée une macro et pour chaque activité je vais renseigner les cellules qui correspondent aux dates d’exécution de mon activité avec le poids distribué sur chaque jour dans mon onglet.
J'ai utilise un tableau pour charger tous les poids et un autre pour toutes dates (2 ans et 9 mois soit un peu plus de 1000 colonnes), voici ma macro

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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
Sub Weight_Distribution_Baseline()
Dim wkA As Workbook
Set wkA = ThisWorkbook
Dim Data As Worksheet
Set Data = ThisWorkbook.Sheets("BL Data")
Dim BSL As Worksheet
Set BSL = ThisWorkbook.Sheets("Baseline")
Dim FCST As Worksheet
'Set FCST = ThisWorkbook.Sheets("Forecast")
Dim ACT As Worksheet
'Set ACT = ThisWorkbook.Sheets("Actual")
Dim Tab_Weight() As String 'Declaration du tableau 1
Dim Tab_Date() As String 'Declaration du tableau 2
Dim Tab_Dist() As String 'Declaration du tableau 3
Dim File_Path As String, Name_File As String
Dim Scale_Date As Range
Set Scale_Date = BSL.Range("C1")
Dim Date_Bsl As Range
Set Date_Bsl = Data.Range("K6")
Dim Act_ID As Range
Set Act_ID = Data.Range("C6")
Dim Wght As Range
Set Wght = Data.Range("O6")
Dim Data_Date As Range
Set Data_Date = wkA.Sheets("General").Range("C1")
Dim NbLine As Integer
Dim NbCol As Integer
Dim NbDays As Long
Dim Start As Long
Dim Project_Start As Range
Set Project_Start = Data.Range("D2")
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim T As Double
 T = Timer
 
With wkA.Sheets("BL Data")
    NbLine = .Cells(.Rows.Count, 4).End(xlUp).Row ' Compte le nombre de ligne de la feuille BL_DATA
End With
 
With wkA.Sheets("Baseline")
    NbCol = Scale_Date.End(xlToRight).Column - 2 'On compte le nombre de colonne a partir de la cellule C1 (-2)
End With
 
ReDim Tab_Weight(0 To NbLine)
 
For i = 0 To UBound(Tab_Weight)
Tab_Weight(i) = Wght.Offset(i, 0)
Next i
 
ReDim Tab_Date(0 To NbCol)
 
For j = 0 To UBound(Tab_Date)
Tab_Date(j) = Scale_Date.Offset(0, j)
Next j
 
For i = 0 To NbLine - 5
 
    If Date_Bsl.Offset(i, 0) < Project_Start Then 'Si l'activite a commence avant le debut du projet
        Start = Project_Start
    ElseIf Date_Bsl.Offset(i, 0) >= Project_Start Then 'Si l'activite a commence apres le debut du projet
        Start = Date_Bsl.Offset(i, 0)
    End If
 
    NbDays = Date_Bsl.Offset(i, 1) - Start
 
    If NbDays <= 0 Then
    NbDays = 1
    End If
    k = 0
    j = 0
 
    If Wght.Offset(i, 0) <> 0 Then ' Si le poids de l'activite n'est pas nul
        While k <= NbDays ' + 1
 
           If NbDays > 1 And Start <> Project_Start And InStr(Date_Bsl.Offset(i, 0), Scale_Date.Offset(0, j)) Then
              For k = 0 To NbDays
                   Scale_Date.Offset(i + 1, j + k) = Tab_Weight(i) / (NbDays + 1)  ' Ici on precise (i+1) car Scale_Date a pour Ref C1
              Next k
           End If
 
           If NbDays > 1 And Start = Project_Start Then
              For k = 0 To NbDays
                   Scale_Date.Offset(i + 1, j + k) = Tab_Weight(i) / (NbDays + 1)  ' Ici on precise (i+1) car Scale_Date a pour Ref C1
              Next k
           End If
 
           If NbDays = 1 And Start > Project_Start And InStr(Date_Bsl.Offset(i, 0), Scale_Date.Offset(0, j)) Then
           Scale_Date.Offset(i + 1, j + k) = Tab_Weight(i)
           k = k + 1
           ElseIf NbDays = 1 And Start = Project_Start Then
           k = k + 1
           End If
           j = j + 1
 
        Wend
 
        If NbDays = 1 And Date_Bsl.Offset(i, 0) <= Project_Start Then
              Scale_Date.Offset(i + 1, 0) = Tab_Weight(i)
              k = k + 1
        End If
    Else
    Scale_Date.Offset(i + 1, 0) = "0"
    End If
Next i
 
MsgBox Application.Round((Timer - T), 1) & " Sec"
 
End Sub

Cette macro fonctionne et met 6 minutes pour s’exécuter.
J'ai donc pensé travailler directement dans un tableau pour aller plus vite et de mettre le total calculé pour chaque jours dans un onglet , donc dans seulement 1000 cellules et quelque.
Je vais donc charger mes tableaux, effectuer ma répartition a l’intérieur de l'un deux puis renseigner mes cellules à la fin.
Voici le résultat

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
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
 
Sub Weight_Distribution_Baseline_Using_Vba_Table()
Dim wkA As Workbook
Set wkA = ThisWorkbook
Dim Data As Worksheet
Set Data = ThisWorkbook.Sheets("BL Data")
Dim TRT As Worksheet
Set TRT = ThisWorkbook.Sheets("Treatment")
Dim BSL As Worksheet
Set BSL = ThisWorkbook.Sheets("Baseline")
Dim FCST As Worksheet
'Set FCST = ThisWorkbook.Sheets("Forecast")
Dim ACT As Worksheet
'Set ACT = ThisWorkbook.Sheets("Actual")
Dim Tab_Weight() As String 'Declaration du tableau 1
Dim Tab_Date() As String 'Declaration du tableau 2
Dim Tab_Dist() 'As String 'Declaration du tableau 3
Dim Tab_Bsl() 'As String 'Declaration du tableau 4
Dim File_Path As String, Name_File As String
Dim Scale_Date As Range
Set Scale_Date = BSL.Range("C1")
Dim Date_Bsl As Range
Set Date_Bsl = Data.Range("K6")
Dim Act_ID As Range
Set Act_ID = Data.Range("C6")
Dim Wght As Range
Set Wght = Data.Range("O6")
Dim Data_Date As Range
Dim BslTrt As Range
Set BslTrt = TRT.Range("C5")
Set Data_Date = wkA.Sheets("General").Range("C1")
Dim NbLine As Integer
Dim NbCol As Integer
Dim NbDays As Long
Dim Start As Long
Dim Project_Start As Range
Set Project_Start = Data.Range("D2")
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim T As Double
T = Timer
 
'Exemple pour lire valeur Table:Debug.Print Tab_Dist(i, j + k)
 
With wkA.Sheets("BL Data")
    NbLine = .Cells(.Rows.Count, 4).End(xlUp).Row ' Compte le nombre de ligne de la feuille BL_DATA
End With
 
With wkA.Sheets("Baseline")
    NbCol = Scale_Date.End(xlToRight).Column - 2 'On compte le nombre de colonne a partir de la cellule C1 (-2)
End With
 
ReDim Tab_Weight(0 To NbLine)
 
For i = 0 To UBound(Tab_Weight)
Tab_Weight(i) = Wght.Offset(i, 0)
Next i
 
ReDim Tab_Date(0 To NbCol)
 
For j = 0 To UBound(Tab_Date)
Tab_Date(j) = Scale_Date.Offset(0, j)
Next j
 
ReDim Tab_Dist(0 To NbLine, 0 To NbCol * 2) 'Ici on redimensionne la deuxieme dimension du tableau en multipliant par deux
                                            ' car on peut avoir une valeur > a NbCol si k>1
For i = 0 To NbLine - 5
 
    If Date_Bsl.Offset(i, 0) < Project_Start Then 'Si l'activite a commence avant le debut du projet
        Start = Project_Start
    ElseIf Date_Bsl.Offset(i, 0) >= Project_Start Then 'Si l'activite a commence apres le debut du projet
        Start = Date_Bsl.Offset(i, 0)
    End If
 
    NbDays = Date_Bsl.Offset(i, 1) - Start
 
    If NbDays <= 0 Then
    NbDays = 1
    End If
    k = 0
    j = 0
 
    If Wght.Offset(i, 0) <> 0 Then
        While k <= NbDays ' + 1
 
           If NbDays > 1 And Start <> Project_Start And InStr(Date_Bsl.Offset(i, 0), Scale_Date.Offset(0, j)) Then
              For k = 0 To NbDays
                   Tab_Dist(i, j + k) = Tab_Weight(i) / (NbDays + 1)   ' Ici on precise (i+1) car Scale_Date a pour Ref C1
              Next k
           End If
 
           If NbDays > 1 And Start = Project_Start Then
              For k = 0 To NbDays
                   Tab_Dist(i, j + k) = Tab_Weight(i) / (NbDays + 1)   ' Ici on precise (i+1) car Scale_Date a pour Ref C1
              Next k
           End If
 
           If NbDays = 1 And Start > Project_Start And InStr(Date_Bsl.Offset(i, 0), Scale_Date.Offset(0, j)) Then
           Tab_Dist(i, j + k) = Tab_Weight(i)
           k = k + 1
           ElseIf NbDays = 1 And Start = Project_Start Then
           k = k + 1
           End If
           j = j + 1
 
        Wend
 
        If NbDays = 1 And Date_Bsl.Offset(i, 0) <= Project_Start Then
              Tab_Dist(i, 0) = Tab_Weight(i)
              k = k + 1
        End If
    Else
    Tab_Dist(i + 1, 0) = "0"
    End If
Next i
 
ReDim Tab_Bsl(0 To NbCol)
 
For i = 0 To NbCol
    For j = 0 To NbLine
        Tab_Bsl(i) = Tab_Dist(j, i) + Tab_Bsl(i)
        Debug.Print Tab_Bsl(i)
    Next j
Next i
 
For i = 0 To NbCol
     BslTrt.Offset(0, i).Value = Tab_Bsl(i)
Next i
 
 
MsgBox Application.Round((Timer - T), 1) & " Sec"
 
End Sub

Contre toute attente, ce dernier code est plus lent que le premier, entre 9 et 10 minutes.
Ayant lu que l'utilisation des tableaux pouvait accélérer le traitement, je commence a m'y mettre, mais le résultat n'est pas convainquant pour l'utilisation que j'en fais en tout cas.
Ai-je encore zappé quelque chose?
Merci pour vos conseils
Eric

Macro avec Tableau en VBA et temps d'execution

Macros et VBA Excel

Mode arborescent

Discussions similaires

Partager

Partager