Transformation d'une VBA Excel dans Access

**europeest** · 16/03/2012, 16h32

Bonjour a tous

j'ai fait realiser une VBA sous Excel dont le but est de generer toutes les combinaisons possibles de differentes categories de magasins dans un centre commercial.

Sous Excel 2010, tout fonctionne jusqu'a un nombre de requetes (avec maximum de boutiques par categorie de 10) de 32 767 combinaisons possibles. a partir de ce nombre, je recois une erreur Runtime Error 6 - Overflow, ou bien la macro plante.

Serait-il possible de transferer ce VBA sous Access afin de profiter:
- de la puissance de calcul d'access compare a Excel
- d'une limitation moindre du nombre de combinaisons (1 millions sous Excel)
- de la possibilite d'augmenter le nombre de categories (jusqu'a 30) et le nombre maximum de boutiques par categorie (jusqu'a 20) ainsi que la cible (jusqu'a 200).

Idealement pour la suite des calculs, le nombre de combinaisons unique ne doit pas depasser le million.

Merci pour vos conseils, et idees pour transferer ce modele sous Access.

Invité · 16/03/2012, 16h59

Bonjour

D'abord il faudrait expliquer ce que fait ton code au lieu de mettre un fichier qui en plus est zippé dans une extension non standard (préférer le .zip)

Le fait de mettre un fichier en pièce jointe ne sera pas utile, car beaucoup de membres ne peuvent ou ne veulent décharger des fichiers.

Donc une explication clair avec le code (en n'oubliant pas les balises, c'est dans les règles) sera préférable.

Philippe

**europeest** · 16/03/2012, 17h19

Tres bien, j'inclus donc le code ci-dessous.

Le but de ce code est de lister dans une page de résultat toutes les combinaisons possibles d'un agencement de boutiques pour un centre commercial donne.

Ex: un centre commercial possède 120 boutiques. Ces boutiques sont classées en catégories (20 catégories différentes par exemple), et pour chacune des catégories, il y a un maximum de boutiques possibles - entre 1 et 20).

Le code va donc élaborer pour un nombre de boutiques défini chaque combinaison et les présenter dans un tableau de résultat

Serait-il possible de transferer ce VBA sous Access afin de profiter:
- de la puissance de calcul d'access compare a Excel
- d'une limitation moindre du nombre de combinaisons (1 millions sous Excel)
- de la possibilite d'augmenter le nombre de categories (jusqu'a 30) et le nombre maximum de boutiques par categorie (jusqu'a 20) ainsi que la cible (jusqu'a 200).

Idealement pour la suite des calculs, le nombre de combinaisons unique ne doit pas depasser le million.

Merci pour vos conseils, et idees pour realiser ce modele sous Access.

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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
Option Explicit
 
 
Sub Schemas()
 
Dim w As Worksheet, p%(1 To 4), i%, c%, Tp%(), j%, d&, b As Long, Tz#(), Pb%(), f%
 
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
 
    Set w = Worksheets("Param")
 
    d = w.Cells(Rows.Count, 2).End(xlUp).Row
 
    If d < 2 Then
        MsgBox "Aucune données trouvées"
        Exit Sub
    End If
    For i = 1 To 2
        If w.Cells(Rows.Count, 2 + i).End(xlUp).Row <> d Then
            MsgBox "Toutes les colonnes n'ont pas le même nombre de données"
            Exit Sub
        End If
    Next i
 
    'Parametres individuels
    p(1) = w.Cells(2, 2) 'minmin
    p(2) = w.Cells(2, 3) 'maxmax
    p(3) = w.Cells(2, 4) 'nb de categories
    p(4) = w.Cells(2, 5) 'cible
    For i = 3 To d
        If w.Cells(i, 2) <> p(1) Then
            MsgBox "Tous les minimums ne sont pas égaux"
            Exit Sub
        End If
        If w.Cells(i, 3) > p(2) Then
            MsgBox "Les maximums doivent être en ordre décroissant"
            Exit Sub
        End If
        p(3) = p(3) + w.Cells(i, 4)
    Next i
 
    If Not (p(3) * p(1) <= p(4) And p(3) * p(2) >= p(4)) Then
        MsgBox "Aucun schéma possible avec ces données"
        Exit Sub
    End If
 
 
    'Parametres tableau
    For i = 2 To d
        b = False
        If i > 2 Then
            If Tp(2, c) = w.Cells(i, 3) Then b = True
        End If
        If b Then
            Tp(3, c) = Tp(3, c) + w.Cells(i, 4) 'occurences
        Else
            c = c + 1
            ReDim Preserve Tp(1 To 4, 1 To c)
            Tp(1, c) = w.Cells(i, 2) 'minimum
            Tp(2, c) = w.Cells(i, 3) 'maximum
            Tp(3, c) = w.Cells(i, 4) 'occurences
        End If
        f = f + 1
        ReDim Preserve Pb(1 To 4, 1 To f)
        Pb(1, f) = w.Cells(i, 2) 'minimum
        Pb(2, f) = w.Cells(i, 3) 'maximum
        Pb(3, f) = w.Cells(i, 4) 'occurences
    Next i
    Tp(4, 1) = Tp(3, 1) 'cumul des occurences
    Pb(4, 1) = Pb(3, 1) 'cumul des occurences
    For i = 2 To c
        Tp(4, i) = Tp(4, i - 1) + Tp(3, i)
    Next i
    For i = 2 To f
        Pb(4, i) = Pb(4, i - 1) + Pb(3, i)
    Next i
 
    If ActiveSheet Is w Then Sheets.Add
 
    c = 0
 
    Tz = Sequences(p(), Tp())
    For i = 1 To UBound(Tz, 2)
        For j = 1 To UBound(Tz, 1)
            Cells(i, j) = Tz(j, i)
        Next j
    Next i
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Function NbComb#(Tc%(), Td%())
Dim Tb%(), c%, j%, s%, f#, Te%(), k%, n%
        c = 1
        ReDim Te(1 To UBound(Td, 2))
        For j = 1 To UBound(Td, 2)
            Te(j) = Td(4, j)
        Next j
        ReDim Tb(1 To 2, 1 To c)
        Tb(1, c) = Tc(1): Tb(2, c) = 1
        For j = 2 To UBound(Tc)
            Select Case Tc(j)
                Case 0
                    Exit For
                Case Tb(1, UBound(Tb, 2))
                    Tb(2, c) = Tb(2, c) + 1
                Case Else
                    c = c + 1
                    ReDim Preserve Tb(1 To 2, 1 To c)
                    Tb(1, c) = Tc(j): Tb(2, c) = 1
            End Select
        Next j
 
        NbComb = 1
        For j = 1 To UBound(Tb, 2)
            s = 0
            For k = 1 To UBound(Td, 2)
                Select Case Tb(1, j)
                    Case Td(2, k)
                        s = Te(k)
                        n = k
                        Exit For
                    Case Is > Td(2, k)
                        s = Te(k - 1)
                        n = k - 1
                        Exit For
                End Select
            Next k
            If s = 0 Then
                s = Te(UBound(Te))
                n = UBound(Te)
            End If
            NbComb = NbComb * WorksheetFunction.Combin(s, Tb(2, j))
            For k = 1 To UBound(Td, 2)
                If n <= k Then
                    Te(k) = Te(k) - Tb(2, j)
                End If
            Next k
        Next j
End Function
 
Function fFiltrage(Tc%(), Td%(), Mn%, Mx%) As Boolean
Dim i%, j%, Te%()
        fFiltrage = True
        ReDim Te(Mn To Mx)
        For i = 1 To UBound(Tc)
            For j = Mn To Tc(i)
                Te(j) = Te(j) + 1
            Next j
        Next i
        For i = Mn To Mx
            If Te(i) > Td(i) Then
                fFiltrage = False
                Exit Function
            End If
        Next i
End Function
 
 
Function fCombinN1(Mx%, Cat%, Cbl%) As Integer()
'combinaison de départ
Dim d%, s%, Tb%(), c%
    d = Mx + 1
    Do
        d = d - 1: s = 0: c = 0
        Do
            c = c + 1
            ReDim Preserve Tb(1 To c)
            Tb(c) = d: s = s + Tb(c)
            If s > Cbl Then
                s = s - d: Tb(c) = Cbl - s: s = s + Tb(c)
            End If
        Loop Until s = Cbl Or c = Cat
    Loop Until s = Cbl
    ReDim Preserve Tb(1 To Cat)
    fCombinN1 = Tb
End Function
 
Function fNextSchema(Tb%(), Cbl%) As Integer()
Dim e%, a%, j%, b(1 To 3) As Boolean, s%, c%, k%, Ts%()
    e = 1: Ts = Tb
    Do
        If e = 1 And b(3) Then
            fNextSchema = Tb
            Exit Function
        End If
        a = 0: b(3) = True
        For j = UBound(Tb) To 1 Step -1
            b(1) = False
            If Tb(j) > 1 Then
                a = a + 1
                If a = e Then
                    s = 0: c = Tb(j)
                    For k = 1 To j - 1
                        s = s + Tb(k)
                    Next k
                    s = Cbl - s
                    For k = j To UBound(Tb)
                        If c - 1 < s Then
                            Tb(k) = c - 1: s = s - Tb(k)
                        Else
                            Tb(k) = s: s = 0
                        End If
                    Next k
                    b(1) = True
                End If
            End If
            If b(1) Then
                s = 0
                For k = 1 To UBound(Tb)
                    s = s + Tb(k)
                Next k
                If s <> Cbl Then
                    For k = 1 To UBound(Tb)
                        Tb(k) = Ts(k)
                    Next k
                    e = e + 1
                    If e = UBound(Tb) + 1 Then
                        ReDim Tb(1 To 1)
                        Tb(1) = 0
                        fNextSchema = Tb
                        Exit Function
                    End If
                Else
                    e = 1
                End If
                Exit For
            End If
        Next j
    Loop
 
End Function
 
Function Sequences(p%(), Tp%()) As Double()
Dim c%, Ta%(), i%, j%, Tb%(), r%, b As Boolean, Tr#(), Te#
 
    c = 0
 
    'Tableau nbre d'occurences max autorisées pour chaque valeur possible
    ReDim Ta(p(1) To p(2))
    For i = p(1) To p(2)
        For j = 1 To UBound(Tp, 2)
            If i >= Tp(1, j) And i <= Tp(2, j) Then
                Ta(i) = Ta(i) + Tp(3, j)
            End If
        Next j
    Next i
 
    'Schema de départ
    Tb = fCombinN1(p(2), p(3), p(4))
 
    Do
        If fFiltrage(Tb(), Ta(), p(1), p(2)) Then
            r = r + 1: b = False
            ReDim Preserve Tr(1 To UBound(Tb) + 1, 1 To r)
            For i = 1 To UBound(Tb)
                Tr(i, r) = Tb(i)
                'Cells(r, i) = Tb(i)
                If Tb(i) > 1 Then b = True
            Next i
            Tr(i, r) = NbComb(Tb, Tp())
            'Cells(r, UBound(Tb) + 1) = NbComb(Tb, Tp())
            If Not b Then Exit Do
        End If
        Tb = fNextSchema(Tb(), p(4))
        If Tb(1) = 0 Then Exit Do
    Loop
    Sequences = Tr
End Function

**User** · 18/03/2012, 21h52

Bonjour,

Envoyé par europeest

Sous Excel 2010, tout fonctionne jusqu'a un nombre de requetes (avec maximum de boutiques par categorie de 10) de 32 767 combinaisons possibles. a partir de ce nombre, je recois une erreur Runtime Error 6 - Overflow, ou bien la macro plante...

Déjà il faut que vous passiez les entiers en entiers longs dans tout le module:

Remplacer "Integer" en "Long"

et

"%" par "&"

Pour dépasser cette limite de 32 767.

Ensuite si vous souhaitez augmenter les valeurs de paramétrage de façon significative il faudra laisser tourner la machine un bon moment avec éventuellement un plantage possible

.

D'autre part la seul utilité d'Access par rapport à Excel c'est au niveaux du nombre de lignes renvoyées. Excel est limitée à 65536 lignes je crois.

Voici votre code Excel modifié (avec les entiers longs) fonctionnel sous Excel seulement:

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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
Option Explicit
 
Sub Schemas()
 
Dim w As Worksheet, p&(1 To 4), i&, c&, Tp&(), j&, d&, b As Long, Tz#(), Pb&(), f&
 
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
 
    Set w = Worksheets("Param")
 
    d = w.Cells(Rows.Count, 2).End(xlUp).Row
 
    If d < 2 Then
        MsgBox "Aucune données trouvées"
        Exit Sub
    End If
    For i = 1 To 2
        If w.Cells(Rows.Count, 2 + i).End(xlUp).Row <> d Then
            MsgBox "Toutes les colonnes n'ont pas le même nombre de données"
            Exit Sub
        End If
    Next i
 
    'Parametres individuels
    p(1) = w.Cells(2, 2) 'minmin
    p(2) = w.Cells(2, 3) 'maxmax
    p(3) = w.Cells(2, 4) 'nb de categories
    p(4) = w.Cells(2, 5) 'cible
    For i = 3 To d
        If w.Cells(i, 2) <> p(1) Then
            MsgBox "Tous les minimums ne sont pas égaux"
            Exit Sub
        End If
        If w.Cells(i, 3) > p(2) Then
            MsgBox "Les maximums doivent être en ordre décroissant"
            Exit Sub
        End If
        p(3) = p(3) + w.Cells(i, 4)
    Next i
 
    If Not (p(3) * p(1) <= p(4) And p(3) * p(2) >= p(4)) Then
        MsgBox "Aucun schéma possible avec ces données"
        Exit Sub
    End If
 
 
    'Parametres tableau
    For i = 2 To d
        b = False
        If i > 2 Then
            If Tp(2, c) = w.Cells(i, 3) Then b = True
        End If
        If b Then
            Tp(3, c) = Tp(3, c) + w.Cells(i, 4) 'occurences
        Else
            c = c + 1
            ReDim Preserve Tp(1 To 4, 1 To c)
            Tp(1, c) = w.Cells(i, 2) 'minimum
            Tp(2, c) = w.Cells(i, 3) 'maximum
            Tp(3, c) = w.Cells(i, 4) 'occurences
        End If
        f = f + 1
        ReDim Preserve Pb(1 To 4, 1 To f)
        Pb(1, f) = w.Cells(i, 2) 'minimum
        Pb(2, f) = w.Cells(i, 3) 'maximum
        Pb(3, f) = w.Cells(i, 4) 'occurences
    Next i
    Tp(4, 1) = Tp(3, 1) 'cumul des occurences
    Pb(4, 1) = Pb(3, 1) 'cumul des occurences
    For i = 2 To c
        Tp(4, i) = Tp(4, i - 1) + Tp(3, i)
    Next i
    For i = 2 To f
        Pb(4, i) = Pb(4, i - 1) + Pb(3, i)
    Next i
 
    If ActiveSheet Is w Then Sheets.Add
 
    c = 0
 
    Tz = Sequences(p(), Tp())
    For i = 1 To UBound(Tz, 2)
        For j = 1 To UBound(Tz, 1)
            Cells(i, j) = Tz(j, i)
        Next j
    Next i
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Function NbComb#(Tc&(), Td&())
Dim Tb&(), c&, j&, s&, f#, Te&(), k&, n&
        c = 1
        ReDim Te(1 To UBound(Td, 2))
        For j = 1 To UBound(Td, 2)
            Te(j) = Td(4, j)
        Next j
        ReDim Tb(1 To 2, 1 To c)
        Tb(1, c) = Tc(1): Tb(2, c) = 1
        For j = 2 To UBound(Tc)
            Select Case Tc(j)
                Case 0
                    Exit For
                Case Tb(1, UBound(Tb, 2))
                    Tb(2, c) = Tb(2, c) + 1
                Case Else
                    c = c + 1
                    ReDim Preserve Tb(1 To 2, 1 To c)
                    Tb(1, c) = Tc(j): Tb(2, c) = 1
            End Select
        Next j
 
        NbComb = 1
        For j = 1 To UBound(Tb, 2)
            s = 0
            For k = 1 To UBound(Td, 2)
                Select Case Tb(1, j)
                    Case Td(2, k)
                        s = Te(k)
                        n = k
                        Exit For
                    Case Is > Td(2, k)
                        s = Te(k - 1)
                        n = k - 1
                        Exit For
                End Select
            Next k
            If s = 0 Then
                s = Te(UBound(Te))
                n = UBound(Te)
            End If
            NbComb = NbComb * WorksheetFunction.Combin(s, Tb(2, j))
            For k = 1 To UBound(Td, 2)
                If n <= k Then
                    Te(k) = Te(k) - Tb(2, j)
                End If
            Next k
        Next j
End Function
 
Function fFiltrage(Tc&(), Td&(), Mn&, Mx&) As Boolean
Dim i&, j&, Te&()
        fFiltrage = True
        ReDim Te(Mn To Mx)
        For i = 1 To UBound(Tc)
            For j = Mn To Tc(i)
                Te(j) = Te(j) + 1
            Next j
        Next i
        For i = Mn To Mx
            If Te(i) > Td(i) Then
                fFiltrage = False
                Exit Function
            End If
        Next i
End Function
 
 
Function fCombinN1(Mx&, Cat&, Cbl&) As Long()
'combinaison de départ
Dim d&, s&, Tb&(), c&
    d = Mx + 1
    Do
        d = d - 1: s = 0: c = 0
        Do
            c = c + 1
            ReDim Preserve Tb(1 To c)
            Tb(c) = d: s = s + Tb(c)
            If s > Cbl Then
                s = s - d: Tb(c) = Cbl - s: s = s + Tb(c)
            End If
        Loop Until s = Cbl Or c = Cat
    Loop Until s = Cbl
    ReDim Preserve Tb(1 To Cat)
    fCombinN1 = Tb
End Function
 
Function fNextSchema(Tb&(), Cbl&) As Long()
Dim e&, a&, j&, b(1 To 3) As Boolean, s&, c&, k&, Ts&()
    e = 1: Ts = Tb
    Do
        If e = 1 And b(3) Then
            fNextSchema = Tb
            Exit Function
        End If
        a = 0: b(3) = True
        For j = UBound(Tb) To 1 Step -1
            b(1) = False
            If Tb(j) > 1 Then
                a = a + 1
                If a = e Then
                    s = 0: c = Tb(j)
                    For k = 1 To j - 1
                        s = s + Tb(k)
                    Next k
                    s = Cbl - s
                    For k = j To UBound(Tb)
                        If c - 1 < s Then
                            Tb(k) = c - 1: s = s - Tb(k)
                        Else
                            Tb(k) = s: s = 0
                        End If
                    Next k
                    b(1) = True
                End If
            End If
            If b(1) Then
                s = 0
                For k = 1 To UBound(Tb)
                    s = s + Tb(k)
                Next k
                If s <> Cbl Then
                    For k = 1 To UBound(Tb)
                        Tb(k) = Ts(k)
                    Next k
                    e = e + 1
                    If e = UBound(Tb) + 1 Then
                        ReDim Tb(1 To 1)
                        Tb(1) = 0
                        fNextSchema = Tb
                        Exit Function
                    End If
                Else
                    e = 1
                End If
                Exit For
            End If
        Next j
    Loop
 
End Function
 
Function Sequences(p&(), Tp&()) As Double()
Dim c&, Ta&(), i&, j&, Tb&(), r&, b As Boolean, Tr#(), Te#
 
    c = 0
 
    'Tableau nbre d'occurences max autorisées pour chaque valeur possible
    ReDim Ta(p(1) To p(2))
    For i = p(1) To p(2)
        For j = 1 To UBound(Tp, 2)
            If i >= Tp(1, j) And i <= Tp(2, j) Then
                Ta(i) = Ta(i) + Tp(3, j)
            End If
        Next j
    Next i
 
    'Schema de départ
    Tb = fCombinN1(p(2), p(3), p(4))
 
    Do
        If fFiltrage(Tb(), Ta(), p(1), p(2)) Then
            r = r + 1: b = False
            ReDim Preserve Tr(1 To UBound(Tb) + 1, 1 To r)
            For i = 1 To UBound(Tb)
                Tr(i, r) = Tb(i)
                'Cells(r, i) = Tb(i)
                If Tb(i) > 1 Then b = True
            Next i
            Tr(i, r) = NbComb(Tb, Tp())
            'Cells(r, UBound(Tb) + 1) = NbComb(Tb, Tp())
            If Not b Then Exit Do
        End If
        Tb = fNextSchema(Tb(), p(4))
        If Tb(1) = 0 Then Exit Do
    Loop
    Sequences = Tr
End Function

QUESTION:

Souhaitez-vous vraiment essayer sous Access

A+

Denis

**europeest** · 19/03/2012, 21h53

Bonjour Denis

merci beaucoup pour votre aide, cela marche bien sous Excel 2007 (maximum de lignes - un peu plus d'un millions).

Pour indication, si le nombre de lignes obtenu est inferieur a un million, il n'y a pas de plantage, et le calcul se fait correctement.

Par exemple, pour une cible de 100, avec 20 categories dont la somme des maximum par categorie est egale a 122, on obtient desormais en pres d'une heure de calcul le nombre de 773 000 lignes representant pres de 6 milliards de combinaisons au total.

Par contre, avec une cible de 75, avec 20 categories dont la somme des maximum par categorie est de 128, au bout de deux heures de calcul, la machine plante affichant le premier million de lignes, et plantant ensuite....

Maintenant, ma question est si l'on transpose ce VBA sous Access, qu'y gagne-t-on en puissance de traitement, et peut on eviter a la machine de planter si l'on depasse le nombre du million de lignes obtenues?

Merci pour vos conseils

Cordialement

**User** · 19/03/2012, 22h48

Bonjour,

Niveau performance je ne penses pas que tu gagnes grand chose avec Access.

Maintenant pour le nombre de lignes c'est vrai qu' Excel 2007 est limité à 1 048 576 lignes (d'après ce que j'ai pu lire).

Dans ce cas pourquoi ne pas répartir les résultats sur plusieurs feuilles Excel pour dépasser cette limite ?

**europeest** · 20/03/2012, 06h34

Bonjour Denis

pour la puissance de calcul, ce n'est pas primordial d'en gagner, le plus important est de pouvoir effectuer le calcul et de le finir sans planter. Access peut il resoudre un tel volume de donnees??

Exemple: Cible 100, nombre de categories: 30, somme des maximum: 150.

Oui, pourquoi pas repartir les resultats sur plusieurs feuilles - est-il possible de modifier le VBA pour qu'il affiche au maximum 1 millions de lignes par feuille?

cordialement

**User** · 20/03/2012, 11h08

Bonjour,

Voici le code pour répartir sur plusieurs feuilles:

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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
 
Option Explicit
 
Sub Schemas()
 
Dim w As Worksheet, p&(1 To 4), i&, c&, Tp&(), j&, d&, b As Long, Tz#(), Pb&(), f&, l&
 
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
 
    Set w = Worksheets("Param")
 
    d = w.Cells(Rows.Count, 2).End(xlUp).Row
 
    If d < 2 Then
        MsgBox "Aucune données trouvées"
        Exit Sub
    End If
    For i = 1 To 2
        If w.Cells(Rows.Count, 2 + i).End(xlUp).Row <> d Then
            MsgBox "Toutes les colonnes n'ont pas le même nombre de données"
            Exit Sub
        End If
    Next i
 
    'Parametres individuels
    p(1) = w.Cells(2, 2) 'minmin
    p(2) = w.Cells(2, 3) 'maxmax
    p(3) = w.Cells(2, 4) 'nb de categories
    p(4) = w.Cells(2, 5) 'cible
    For i = 3 To d
        If w.Cells(i, 2) <> p(1) Then
            MsgBox "Tous les minimums ne sont pas égaux"
            Exit Sub
        End If
        If w.Cells(i, 3) > p(2) Then
            MsgBox "Les maximums doivent être en ordre décroissant"
            Exit Sub
        End If
        p(3) = p(3) + w.Cells(i, 4)
    Next i
 
    If Not (p(3) * p(1) <= p(4) And p(3) * p(2) >= p(4)) Then
        MsgBox "Aucun schéma possible avec ces données"
        Exit Sub
    End If
 
 
    'Parametres tableau
    For i = 2 To d
        b = False
        If i > 2 Then
            If Tp(2, c) = w.Cells(i, 3) Then b = True
        End If
        If b Then
            Tp(3, c) = Tp(3, c) + w.Cells(i, 4) 'occurences
        Else
            c = c + 1
            ReDim Preserve Tp(1 To 4, 1 To c)
            Tp(1, c) = w.Cells(i, 2) 'minimum
            Tp(2, c) = w.Cells(i, 3) 'maximum
            Tp(3, c) = w.Cells(i, 4) 'occurences
        End If
        f = f + 1
        ReDim Preserve Pb(1 To 4, 1 To f)
        Pb(1, f) = w.Cells(i, 2) 'minimum
        Pb(2, f) = w.Cells(i, 3) 'maximum
        Pb(3, f) = w.Cells(i, 4) 'occurences
    Next i
    Tp(4, 1) = Tp(3, 1) 'cumul des occurences
    Pb(4, 1) = Pb(3, 1) 'cumul des occurences
    For i = 2 To c
        Tp(4, i) = Tp(4, i - 1) + Tp(3, i)
    Next i
    For i = 2 To f
        Pb(4, i) = Pb(4, i - 1) + Pb(3, i)
    Next i
 
    If ActiveSheet Is w Then Sheets.Add
 
    c = 0: l = 1
 
    Tz = Sequences(p(), Tp())
    For i = 1 To UBound(Tz, 2)
 
        If (l > 1000000) Then
           l = 1
           Sheets.Add
        End If
 
        For j = 1 To UBound(Tz, 1)
            Cells(l, j) = Tz(j, i)
        Next j
 
        l = l + 1
 
    Next i
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Function NbComb#(Tc&(), Td&())
Dim Tb&(), c&, j&, s&, f#, Te&(), k&, n&
        c = 1
        ReDim Te(1 To UBound(Td, 2))
        For j = 1 To UBound(Td, 2)
            Te(j) = Td(4, j)
        Next j
        ReDim Tb(1 To 2, 1 To c)
        Tb(1, c) = Tc(1): Tb(2, c) = 1
        For j = 2 To UBound(Tc)
            Select Case Tc(j)
                Case 0
                    Exit For
                Case Tb(1, UBound(Tb, 2))
                    Tb(2, c) = Tb(2, c) + 1
                Case Else
                    c = c + 1
                    ReDim Preserve Tb(1 To 2, 1 To c)
                    Tb(1, c) = Tc(j): Tb(2, c) = 1
            End Select
        Next j
 
        NbComb = 1
        For j = 1 To UBound(Tb, 2)
            s = 0
            For k = 1 To UBound(Td, 2)
                Select Case Tb(1, j)
                    Case Td(2, k)
                        s = Te(k)
                        n = k
                        Exit For
                    Case Is > Td(2, k)
                        s = Te(k - 1)
                        n = k - 1
                        Exit For
                End Select
            Next k
            If s = 0 Then
                s = Te(UBound(Te))
                n = UBound(Te)
            End If
            NbComb = NbComb * WorksheetFunction.Combin(s, Tb(2, j))
            For k = 1 To UBound(Td, 2)
                If n <= k Then
                    Te(k) = Te(k) - Tb(2, j)
                End If
            Next k
        Next j
End Function
 
Function fFiltrage(Tc&(), Td&(), Mn&, Mx&) As Boolean
Dim i&, j&, Te&()
        fFiltrage = True
        ReDim Te(Mn To Mx)
        For i = 1 To UBound(Tc)
            For j = Mn To Tc(i)
                Te(j) = Te(j) + 1
            Next j
        Next i
        For i = Mn To Mx
            If Te(i) > Td(i) Then
                fFiltrage = False
                Exit Function
            End If
        Next i
End Function
 
 
Function fCombinN1(Mx&, Cat&, Cbl&) As Long()
'combinaison de départ
Dim d&, s&, Tb&(), c&
    d = Mx + 1
    Do
        d = d - 1: s = 0: c = 0
        Do
            c = c + 1
            ReDim Preserve Tb(1 To c)
            Tb(c) = d: s = s + Tb(c)
            If s > Cbl Then
                s = s - d: Tb(c) = Cbl - s: s = s + Tb(c)
            End If
        Loop Until s = Cbl Or c = Cat
    Loop Until s = Cbl
    ReDim Preserve Tb(1 To Cat)
    fCombinN1 = Tb
End Function
 
Function fNextSchema(Tb&(), Cbl&) As Long()
Dim e&, a&, j&, b(1 To 3) As Boolean, s&, c&, k&, Ts&()
    e = 1: Ts = Tb
    Do
        If e = 1 And b(3) Then
            fNextSchema = Tb
            Exit Function
        End If
        a = 0: b(3) = True
        For j = UBound(Tb) To 1 Step -1
            b(1) = False
            If Tb(j) > 1 Then
                a = a + 1
                If a = e Then
                    s = 0: c = Tb(j)
                    For k = 1 To j - 1
                        s = s + Tb(k)
                    Next k
                    s = Cbl - s
                    For k = j To UBound(Tb)
                        If c - 1 < s Then
                            Tb(k) = c - 1: s = s - Tb(k)
                        Else
                            Tb(k) = s: s = 0
                        End If
                    Next k
                    b(1) = True
                End If
            End If
            If b(1) Then
                s = 0
                For k = 1 To UBound(Tb)
                    s = s + Tb(k)
                Next k
                If s <> Cbl Then
                    For k = 1 To UBound(Tb)
                        Tb(k) = Ts(k)
                    Next k
                    e = e + 1
                    If e = UBound(Tb) + 1 Then
                        ReDim Tb(1 To 1)
                        Tb(1) = 0
                        fNextSchema = Tb
                        Exit Function
                    End If
                Else
                    e = 1
                End If
                Exit For
            End If
        Next j
    Loop
 
End Function
 
Function Sequences(p&(), Tp&()) As Double()
Dim c&, Ta&(), i&, j&, Tb&(), r&, b As Boolean, Tr#(), Te#
 
    c = 0
 
    'Tableau nbre d'occurences max autorisées pour chaque valeur possible
    ReDim Ta(p(1) To p(2))
    For i = p(1) To p(2)
        For j = 1 To UBound(Tp, 2)
            If i >= Tp(1, j) And i <= Tp(2, j) Then
                Ta(i) = Ta(i) + Tp(3, j)
            End If
        Next j
    Next i
 
    'Schema de départ
    Tb = fCombinN1(p(2), p(3), p(4))
 
    Do
        If fFiltrage(Tb(), Ta(), p(1), p(2)) Then
            r = r + 1: b = False
            ReDim Preserve Tr(1 To UBound(Tb) + 1, 1 To r)
            For i = 1 To UBound(Tb)
                Tr(i, r) = Tb(i)
                'Cells(r, i) = Tb(i)
                If Tb(i) > 1 Then b = True
            Next i
            Tr(i, r) = NbComb(Tb, Tp())
            'Cells(r, UBound(Tb) + 1) = NbComb(Tb, Tp())
            If Not b Then Exit Do
        End If
        Tb = fNextSchema(Tb(), p(4))
        If Tb(1) = 0 Then Exit Do
    Loop
    Sequences = Tr
End Function

En fait j'ai juste modifié la procedure "Schema"...

J'ai aussi une version sous Access mais c'est pas mal plus lent pour l'affichage et ca devrai faire dans les 21 millions de lignes + une requête analyse croisée qui prend du temps pour s'afficher :

En fait une table avec les champs NSerie (ligne),Ncategorie (numéro de catégorie) et valeur (valeur du tableau). Si par exemple vous souhaitez générer 1 million de ligne ça va vous faire 21 millions de lignes (pour les 20 categorie + la colonne tout à droite) et ensuite on utilise une requête croisée pour représenter les résultat sous la forme d'une tableau à 21 colonnes et 1 million de lignes. Donc je n'est pas testé pour de grandes valeurs de paramètres ...

Il faut ouvrir le formulaire "F_Param", définir les paramètres dans le tableau et enfin appuyer sur générer...

A+

**europeest** · 21/03/2012, 11h42

Bonjour Denis

merci pour les modifications. Je teste le format Excel, et la macro Access, et je reviens vers vous rapidement.

Pour Access, quand on obtient le premier calcul decrit ci-dessous
En fait une table avec les champs NSerie (ligne),Ncategorie (numéro de catégorie) et valeur (valeur du tableau). Si par exemple vous souhaitez générer 1 million de ligne ça va vous faire 21 millions de lignes (pour les 20 categorie + la colonne tout à droite) et ensuite on utilise une requête croisée pour représenter les résultat sous la forme d'une tableau à 21 colonnes et 1 million de lignes. Donc je n'est pas testé pour de grandes valeurs de paramètres ...

Comment effectue-t-on la requete croisee? (vraiment novice dans ce domaine)

Cordialement

**User** · 22/03/2012, 17h38

Envoyé par europeest

Comment effectue-t-on la requete croisee? (vraiment novice dans ce domaine)

Cordialement

La requête croisée est déjà présente, il suffit d'appuyer sur le bouton générer et de valider le message qui te demande si tu veux afficher les résultats (après les calculs de l'algo).

A+

**europeest** · 29/03/2012, 12h06

Bonjour Philippe

desole pour le retard dans ma reponse.

Tout fonctionne parfaitement, merci pour votre aide precieuse!

Cordialement

Transformation d'une VBA Excel dans Access

VBA Access

Discussions similaires

Partager

Partager