Macro avec Tableau en VBA et temps d'execution

Version imprimable

1 pièce(s) jointe(s)

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 :
Pièce jointe 199954
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:

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:

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

Bonjour,
Il ya plein de choses qui ne servent à rien dans ton code les variables range et leur set et WorkSeet.
Fais le ménage et évite les boucle pour charger un tableau quand il est possible de le charger directement!
Code:

1 2 3 4 5 With ThisWorkbook.Sheets("BL Data") NbLine = .Cells(.Rows.Count, 4).End(xlUp).Row ' Compte le nombre de ligne de la feuille BL_DATA Tab_Weight = .range(.cells(6,"O"),.cells(NbLine,"O")).value End With
Autre exemple:
Code:

1 2 Tab_Date = Application.WorksheetFunction.Transpose(.range(.cells(6,4),.cells(6,20)).value)

Bonjour,

en m'appuyant scrupuleusement à ta copie écran pour la disposition, et en partant du principe que la première activité est en A3
voici un exemple avec pas mal de variables pour bien comprendre :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub toto()
Dim TabEntree(), NbDate As Long, Poids As Long, PrimoDate As Date
    With ThisWorkbook.Worksheets("Feuil1")
        PrimoDate = .Cells(1, 5).Value
        TabEntree = .Cells(3, 1).Resize(.UsedRange.Rows.Count - 2, 4).Value
        For i = LBound(TabEntree, 1) To UBound(TabEntree, 1)
            NbDate = TabEntree(i, 4) - TabEntree(i, 3) + 1
            Poids = TabEntree(i, 2)
            .Cells(i + 2, TabEntree(i, 3) - PrimoDate + 5).Resize(1, NbDate).Value = Poids / NbDate
        Next i
 
        .Cells(2, 5).Resize(1, .UsedRange.Columns.Count - 4).FormulaR1C1 = "=SUM(R[1]C:R[" & .UsedRange.Rows.Count - 2 & "]C)"
    End With
End Sub

Et la version simplifiée avec une seule variable : le tableau

Code:

1
2
3
4
5
6
7
8
9
10
Sub totos()
Dim TabEntree()
    With ThisWorkbook.Worksheets("Feuil1")
        TabEntree = .Cells(3, 1).Resize(.UsedRange.Rows.Count - 2, 4).Value
        For i = LBound(TabEntree, 1) To UBound(TabEntree, 1)
            .Cells(i + 2, TabEntree(i, 3) - .Cells(1, 5).Value + 5).Resize(1, TabEntree(i, 4) - TabEntree(i, 3) + 1).Value = TabEntree(i, 2) / (TabEntree(i, 4) - TabEntree(i, 3) + 1)
        Next i
        .Cells(2, 5).Resize(1, .UsedRange.Columns.Count - 4).FormulaR1C1 = "=SUM(R[1]C:R[" & .UsedRange.Rows.Count - 2 & "]C)"
    End With
End Sub

On peut encore accélérer le traitement : utiliser un tableau secondaire qui stocke la matrice des résultats pour la restituer d'un bloc sur la plage.

Regarde déjà si ça correspond à ton besoin, et si c'est le cas, indique-nous combien de temps ça met à tourner

04/02/2016, 19h59
eric4459

Bonsoir Robert, bonsoir Joe,
Je regarde demain et vous tiens au courant de l'évolution, merci en tout cas ;-)
Eric
04/02/2016, 20h02
joe.levrai

Je viens de modifier à l'instant mes deux codes, j'avais une petit coquille

à demain

Bonjour a tous,
Merci pour vos conseils
J'ai réparé mon fichier Excel et maintenant ma macro tourne en 43,3 sec :) avec le code suivant pour traiter 6,5 millions de données (980 colonnes x 6614 lignes) :applo:.

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
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 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)
    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

Eric

10/02/2016, 16h38
joe.levrai

Salut Eric,

ravi que tu as atteint ton objectif de réduction du temps de traitement.

mais du coup, je comprend pas pourquoi ton code est encore aussi long et avec autant de variables :weird:

si la disposition de ta copie écran est fidèle à la disposition sur l'une de tes feuilles ... en cas de traitement à faire sur plusieurs feuilles t'a juste 3 lignes de codes à rajouter pour effectuer ce traitement sur plusieurs feuilles de ton choix

sur la structure que tu as montré, 10 lignes de code suffisait
10/02/2016, 18h08
eric4459

Salut Joe,
La copie d’écran que j'ai faite ne venait pas de mon fichier, j'ai crée une feuille pour donner un exemple, le fichier sur lequel je travaille est ici
http://www.sendbox.fr/3d874483963a22...08_-_Copy.xlsm.
Penses-tu que l'on puisse encore réduire le temps de traitement?
Eric
10/02/2016, 18h14
eric4459

Joe,
Voir le Module 3, pour le reste il faut d'autres fichiers
Eric