Simplification de boucles FOR avec concaténation ?

**Masamunai** · 16/03/2010, 19h54

Que ce soit Double ou Single ne change rien au problème: je ne veux pas de ces décimales parasites ou autre arrondissement à chaque rebouclage, la macro devrait me retourner un 100% tout rond (lorsque SommeCible=0 càd on génére tous les uplets) exactement comme quand tu fais le calcul "a la main" ou par ta calculette.

Ex: pour multiplier (0;1) 5.5% x 54% = 0.297% à la main, donc je devrais voir sous Excel une valeur exactement pareil, sans décimales en trop ou je ne sais quoi :/
Pourquoi? parce qu'après, lorsque la simulation récupère ces valeurs avec ces décimales parasites, ben... ca fausse un poil en bout de chaîne :s
L'ancien algo n'avait pas ce problème je comprends paa pour quoi celui là l'aurait ;; parce qu'a part ça il est parfait vraiment...

Pour l'extrait de code, je parlait de ça :

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
        bPositif = True
        SomX = 0
        sCol = 1
        For xDim = 0 To NbrMembres - 1
            If Col(Xx(xDim)) <= 0 Then
                bPositif = False
                Exit For
            End If
            SomX = SomX + Xx(xDim)
            sCol = sCol * Col(Xx(xDim))
        Next
 
        If bPositif And (Cible = 0 Or SomX = Cible) Then
            For xDim = 0 To UBound(Xx)
                Tab_vTmp(xDim) = CStr(Xx(xDim))
            Next

Je me demandais juste s'il y avait encore possibilité de simplifer :p (2 For xDim avec même borne sup, vu que Ubound(Xx) = NbrMembres-1)

**Qwazerty** · 16/03/2010, 20h14

Salut
Il est bien de l'avoir remarqué, mais la solution étant simple, un peu de creusage de tête t'aurais probablement permis de le réaliser toi même

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
        bPositif = True
        SomX = 0
        sCol = 1
        For xDim = 0 To NbrMembres - 1
            If Col(Xx(xDim)) <= 0 Then
                bPositif = False
                Exit For
            End If
            SomX = SomX + Xx(xDim)
            sCol = sCol * Col(Xx(xDim))
            Tab_vTmp(xDim) = CStr(Xx(xDim))
        Next
 
        If bPositif And (Cible = 0 Or SomX = Cible) Then

Et pour les problèmes de précision, ton problème est résolu?
A++
Qwaz

**Masamunai** · 16/03/2010, 20h45

Oui oui t'a bien raison pour la simplif je crois je suis pas loin...

Par contre le pb de précision je n'ai pas la moindre idée quelle solution employer. J'ai essayer de remplacer Single par double ca fait pareil, puis supprimer (pas de type) encore pareil...

**Qwazerty** · 16/03/2010, 21h00

Envoyé par Masamunai

Oui oui t'a bien raison pour la simplif je crois je suis pas loin...

Je te l'ai donné juste au dessus...

Pour ce qui est de Double et Single as tu bien réfléchis a la précision nécessaire et au rendu que te fera la cellule excel étant donné sont niveau de précision a elle?

Quand bien même, as tu pensais a configurer en Double le retour de CompteDoublons?

Code :

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

1
2
Function CompteDoublons(Uplet, Col) As Double ' Comptage du nombre de 
    Dim i As Integer 'correction de cette ligne aussi, 'C' est déclaré mais jamais utilisé

A++
Qwaz

**Masamunai** · 16/03/2010, 23h00

a oui le "C" fantôme , même pas vu XD

Quant à comptedoublons configuré en Double j'avais mis ca au tout début, sans être sûr d'avoir compris je mettait double partout < <
Là c'est Integer je pense.

Merci pour les corrections et la simplif, mais en fait t'avais raison à l'origine de mettre la ligne de génération Tab_vTmp APRES le If conditions (comme dans l'ancien algo d'ailleurs), donc je cherchais à mettre les 2 autres lignes sCol et SomX avec Tab_vTmp. Ce que t'a fait ci-dessus c l'inverse.

En revanche, l'histoire de précision en sortie, toujours rien ne solutionne le probleme... et c'est le plus grave ;;

**Qwazerty** · 17/03/2010, 18h51

Salut
Avant de modifier quoi que ce soit, j'aimerais que tu répondes à la question soulevée plus haut.
De quelle précision as tu besoin, je ne voudrait pas passer plus de temps que nécessaire a retravailler un code pour au final gagné 50 décimales qui ne s'afficheront jamais sur Excel.
A++
Qwaz

**Masamunai** · 17/03/2010, 19h39

D'accord:

En fait, on va prendre un exemple simple : multiplier successivement 1/2.

A la main : 0,5 x 0,5 = 0,25 * 0,5 = 0,125 *0,5 = 0,0625 etc...
(mêmes résultats à la calculette)
Avec ancien algo:
- une multiplication = 0,25
- deux multiplications = 0,125
- trois multiplications = 0,0625 etc...
(j'ai même vérifié en augmentant le nombres de chiffres après la virgule au maximum qu'Excel pouvait = que des 0 donc c'est bon)
Avec la routine CalculProba :
- une multiplication = 0,249999999999999992
- deux multiplications = 0,1249999999999261354
- trois multiplications = 0,0624999999999999999998358 etc...

Donc on voit bien y a un problème non ?

**Qwazerty** · 17/03/2010, 20h41

Salut

Je suis plutôt surpris, si je breack dans la macro je n'ai pas ce type d'arrondi bizarre, ou prends tu ces valeurs?
J'ai fais le teste suivant, j'ai mis uniquement des 50% dans le tableau Data et voila ce qui ressort -> Voir fichier joint.
Et les %tages inscrit dans le fichier excel sont tout aussi rond!

A++
Qwaz

**Masamunai** · 17/03/2010, 21h52

et ca te donne quoi comme resultats pour SommeCible=0 ? (avec tes probas individuelles de telle sorte qu'elles fasse une somme=100%)

Normalement tu devrais avoir un 100% "rond" aussi comme dans ton screenshot. Ce n'est pas mon cas :s

**Qwazerty** · 17/03/2010, 22h38

Salut
Pas de probleme avec Cible a 0.
Je te redonne le code avec lequel je tourne

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
Option Explicit
 
Function Fact(Nombre) As Single
Dim Boucle As Integer
Fact = 1
If Int(Nombre) >= 2 Then
  For Boucle = 2 To Int(Nombre)
    Fact = Fact * Boucle
  Next Boucle
End If
End Function
 
Function CompteDoublons(Uplet, Col) As Single ' Comptage du nombre de répetitions NbR pour chacun des membres de l'uplet
    Dim i As Integer 'correction de cette ligne aussi C est déclaré mais jamais utilisé
    Dim NbR As Integer
 
    CompteDoublons = 1
    For i = 0 To 8
        NbR = 0
        If Col(i) > 0 Then
            NbR = Len(Uplet) - Len(Replace(Uplet, i, ""))
        End If
        CompteDoublons = CompteDoublons * Fact(NbR)
    Next
 
End Function
 
Function CalculProba(MaxN As Integer, NbrMembres As Integer, ByRef Col() As Single, Cible As Integer)
'MaxN correspond a ton ancienne variable N
ReDim Xx(NbrMembres - 1) As Integer 'valeur de 0 à NbrMembres-1
Dim xDim As Integer
Dim SomX As Integer
Dim bPositif As Boolean
Dim sCol As Single
ReDim Tab_vTmp(NbrMembres - 1) As String
ReDim Tab_Retour(2, 0) As Variant
 
 
    'Initialisation
    CalculProba = False
 
    Do
        'Traitement
        'On control que tous les membres de col soit > 0
        bPositif = True
        SomX = 0
        sCol = 1
        For xDim = 0 To NbrMembres - 1
            If Col(Xx(xDim)) <= 0 Then
                bPositif = False
                Exit For
            End If
            SomX = SomX + Xx(xDim)
            sCol = sCol * Col(Xx(xDim))
        Next
 
        If bPositif And (Cible = 0 Or SomX = Cible) Then
            For xDim = 0 To UBound(Xx)
                Tab_vTmp(xDim) = CStr(Xx(xDim))
            Next
            Tab_Retour(0, UBound(Tab_Retour, 2)) = "( " & Join(Tab_vTmp, " ; ") & " )"
            Tab_Retour(1, UBound(Tab_Retour, 2)) = sCol
            Tab_Retour(2, UBound(Tab_Retour, 2)) = Fact(NbrMembres) / CompteDoublons(Tab_Retour(0, UBound(Tab_Retour, 2)), Col)
            CalculProba = Tab_Retour
            ReDim Preserve Tab_Retour(2, UBound(Tab_Retour, 2) + 1)
        End If
 
        'Calcul des membres
        'On incremente le tableau de poid fort
        Xx(NbrMembres - 1) = Xx(NbrMembres - 1) + 1
        'On boucle du tableau de poid le plus faible jusqu'a tableau d'indice NbrMembres-1
        For xDim = NbrMembres - 1 To 1 Step -1
            If Xx(xDim) > MaxN Then Xx(xDim - 1) = Xx(xDim - 1) + 1
        Next
        For xDim = 1 To NbrMembres - 1
            If Xx(xDim) > MaxN Then Xx(xDim) = Xx(xDim - 1)
        Next
    Loop While Xx(0) <= MaxN
 
End Function
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
'Declaration
Dim xDest As Integer
Dim Tab_Result As Variant
Dim bVide As Boolean
 
Dim Cible As Integer, NbM As Integer, cNbM As Integer
Dim x As Integer, N As Integer, R As Integer
 
    'On verifie les conditions d'execution
    If Intersect(Target, Union([Data], [NbMembres], [SomCible])) Is Nothing Then Exit Sub
    If Intersect(Target, Union([Data], [NbMembres], [SomCible])).Cells.Count <> 1 Then
        MsgBox "Vous ne devez pas modifier simultanément le contenu de plusieurs cellules bleues" & vbCrLf & "Les calculs n'ont pas été effectués."
        Exit Sub
    End If
 
    'Initialisation
    Cible = [SomCible].Value
    NbM = [NbMembres].Value
    ReDim Col([Data].Cells.Count - 1) As Single
    R = 0
 
    For x = 1 To [Data].Cells.Count
      Col(x - 1) = [Data].Cells(x).Value2
      If [Data].Cells(x) > 0 Then
        N = x - 1 'Nbre maxi correspondant à la dernière donnée non-nulle
        R = R + 1 'Nbre réel de données non nulles (sans celles nulles avant N)
      End If
    Next x
 
    If Not 2 <= (UBound(Col) - 1) <= 9 Then
        MsgBox "Le Nombre de Probabilité(s) Différente(s) de Zéro n'est pas correct"
        Exit Sub
    End If
    If 1 > NbM Then
        MsgBox "Le Nombre de Membres doit être un Entier superieur a 1"
        Exit Sub
    End If
 
    'Cette partie du code n'etait valable que pour les versions precedant Excel 2007, qui gere plus de 2M de lignes (Integer avant et maintenant Long)
    'Je l'ai rend independante de la version d'excel
    x = 0
    While Fact(R + x) / (Fact(x) * Fact(R)) < (Rows.Count - 1) And x <= NbM 'Protection anti-saturation
        cNbM = x 'Nbre de membres max/uplet corrigé
        x = x + 1
    Wend
 
    ReDim DestRange(2 To cNbM) As Range 'a rendre polyvalent
 
    For xDest = 2 To cNbM 'a rendre polyvalent
        Set DestRange(xDest) = Cells(2, (xDest - 2) * 3 + 12)
    Next
 
    Application.EnableEvents = False
    [Results].Cells.ClearContents
    Application.EnableEvents = True
 
    'Traitement
    'On empeche la mise a jour a l'ecran
    Application.ScreenUpdating = False
    bVide = True
 
    'On boucle en fonction du nombre de membre
    For x = 2 To cNbM 'a rendre polyvalent
        Tab_Result = CalculProba(N, x, Col, Cible)
        If IsArray(Tab_Result) Then
            bVide = False
            Application.EnableEvents = False
            DestRange(x).Resize(UBound(Tab_Result, 2) + 1, 3) = WorksheetFunction.Transpose(Tab_Result)
            Application.EnableEvents = True
        End If
    Next
 
    'On verifie qu'il y a des resultats sinon on vide tout et on quitte
    If bVide Then
        MsgBox "Aucune permutation ne répond à votre critère de somme (" & Cible & ")"
        Application.EnableEvents = False
        [Results].Cells.ClearContents
        Application.EnableEvents = True
        Exit Sub
    End If
 
    Application.ScreenUpdating = True
 
    If cNbM < NbM Then
      MsgBox "Les permutations " & cNbM + 1 & "-uplets à " & NbM & "-uplets répondant à votre critère de somme (" & Cible & ") n'ont pas été calculés car plus de 65000 possibilités."
    End If
 
End Sub

J'ai remis les single, puisqu'ils semblent bien assez "grand"
A++
Qwaz

**Masamunai** · 18/03/2010, 09h42

Bonjour

Bon... tu ne va plus m'aimer je crois là

1. J'ai vérifié les "As ..." de mon code par rapport au tien, changés certains mais rien n'y fait...
2. J'ai alors carrément fait une copie du Excel, supprimé tout le VBA, puis copié-collé ton code du post au-dessus.
J'obtiens bien les mêmes résultats que ton screenshot pour Som=5 et NbMembres=10, mais pour Som=0 j'obtiens le screenshot ci-dessous...alors que tu m'a dit que tu obtenais des 100% "tout ronds".

Je suis en train de me demander s'il s'agit d'un paramètre foireux de mon Excel, ou pire que mon PC fait des erreurs de calcul ?
Edit: je rajoute un screen des résultats à partir de l'ancien algo.

**Qwazerty** · 18/03/2010, 18h46

Salut
Résultat des courses.
-> passage en Double on obtient

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
Option Explicit
 
Function Fact(Nombre) As Double
Dim Boucle As Integer
Fact = 1
If Int(Nombre) >= 2 Then
  For Boucle = 2 To Int(Nombre)
    Fact = Fact * Boucle
  Next Boucle
End If
End Function
 
Function CompteDoublons(Uplet, Col) As Double ' Comptage du nombre de répetitions NbR pour chacun des membres de l'uplet
    Dim i As Integer 'correction de cette ligne aussi C est déclaré mais jamais utilisé
    Dim NbR As Integer
 
    CompteDoublons = 1
    For i = 0 To 8
        NbR = 0
        If Col(i) > 0 Then
            NbR = Len(Uplet) - Len(Replace(Uplet, i, ""))
        End If
        CompteDoublons = CompteDoublons * Fact(NbR)
    Next
 
End Function
 
Function CalculProba(MaxN As Integer, NbrMembres As Integer, ByRef Col() As Double, Cible As Integer)
'MaxN correspond a ton ancienne variable N
ReDim Xx(NbrMembres - 1) As Integer 'valeur de 0 à NbrMembres-1
Dim xDim As Integer
Dim SomX As Integer
Dim bPositif As Boolean
Dim sCol As Double
ReDim Tab_vTmp(NbrMembres - 1) As String
ReDim Tab_Retour(2, 0) As Variant
 
 
    'Initialisation
    CalculProba = False
 
    Do
        'Traitement
        'On control que tous les membres de col soit > 0
        bPositif = True
        SomX = 0
        sCol = 1
        For xDim = 0 To NbrMembres - 1
            If Col(Xx(xDim)) <= 0 Then
                bPositif = False
                Exit For
            End If
            SomX = SomX + Xx(xDim)
            sCol = sCol * Col(Xx(xDim))
        Next
 
        If bPositif And (Cible = 0 Or SomX = Cible) Then
            For xDim = 0 To UBound(Xx)
                Tab_vTmp(xDim) = CStr(Xx(xDim))
            Next
            Tab_Retour(0, UBound(Tab_Retour, 2)) = "( " & Join(Tab_vTmp, " ; ") & " )"
            Tab_Retour(1, UBound(Tab_Retour, 2)) = sCol
            Tab_Retour(2, UBound(Tab_Retour, 2)) = Fact(NbrMembres) / CompteDoublons(Tab_Retour(0, UBound(Tab_Retour, 2)), Col)
            CalculProba = Tab_Retour
            ReDim Preserve Tab_Retour(2, UBound(Tab_Retour, 2) + 1)
        End If
 
        'Calcul des membres
        'On incremente le tableau de poid fort
        Xx(NbrMembres - 1) = Xx(NbrMembres - 1) + 1
        'On boucle du tableau de poid le plus faible jusqu'a tableau d'indice NbrMembres-1
        For xDim = NbrMembres - 1 To 1 Step -1
            If Xx(xDim) > MaxN Then Xx(xDim - 1) = Xx(xDim - 1) + 1
        Next
        For xDim = 1 To NbrMembres - 1
            If Xx(xDim) > MaxN Then Xx(xDim) = Xx(xDim - 1)
        Next
    Loop While Xx(0) <= MaxN
 
End Function
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
'Declaration
Dim xDest As Integer
Dim Tab_Result As Variant
Dim bVide As Boolean
 
Dim Cible As Integer, NbM As Integer, cNbM As Integer
Dim x As Integer, N As Integer, R As Integer
 
    'On verifie les conditions d'execution
    If Intersect(Target, Union([Data], [NbMembres], [SomCible])) Is Nothing Then Exit Sub
    If Intersect(Target, Union([Data], [NbMembres], [SomCible])).Cells.Count <> 1 Then
        MsgBox "Vous ne devez pas modifier simultanément le contenu de plusieurs cellules bleues" & vbCrLf & "Les calculs n'ont pas été effectués."
        Exit Sub
    End If
 
    'Initialisation
    Cible = [SomCible].Value
    NbM = [NbMembres].Value
    ReDim Col([Data].Cells.Count - 1) As Double
    R = 0
 
    For x = 1 To [Data].Cells.Count
      Col(x - 1) = [Data].Cells(x).Value2
      If [Data].Cells(x) > 0 Then
        N = x - 1 'Nbre maxi correspondant à la dernière donnée non-nulle
        R = R + 1 'Nbre réel de données non nulles (sans celles nulles avant N)
      End If
    Next x
 
    If Not 2 <= (UBound(Col) - 1) <= 9 Then
        MsgBox "Le Nombre de Probabilité(s) Différente(s) de Zéro n'est pas correct"
        Exit Sub
    End If
    If 1 > NbM Then
        MsgBox "Le Nombre de Membres doit être un Entier superieur a 1"
        Exit Sub
    End If
 
    'Cette partie du code n'etait valable que pour les versions precedant Excel 2007, qui gere plus de 2M de lignes (Integer avant et maintenant Long)
    'Je l'ai rend independante de la version d'excel
    x = 0
    While Fact(R + x) / (Fact(x) * Fact(R)) < (Rows.Count - 1) And x <= NbM 'Protection anti-saturation
        cNbM = x 'Nbre de membres max/uplet corrigé
        x = x + 1
    Wend
 
    ReDim DestRange(2 To cNbM) As Range 'a rendre polyvalent
 
    For xDest = 2 To cNbM 'a rendre polyvalent
        Set DestRange(xDest) = Cells(2, (xDest - 2) * 3 + 12)
    Next
 
    Application.EnableEvents = False
    [Results].Cells.ClearContents
    Application.EnableEvents = True
 
    'Traitement
    'On empeche la mise a jour a l'ecran
    Application.ScreenUpdating = False
    bVide = True
 
    'On boucle en fonction du nombre de membre
    For x = 2 To cNbM 'a rendre polyvalent
        Tab_Result = CalculProba(N, x, Col, Cible)
        If IsArray(Tab_Result) Then
            bVide = False
            Application.EnableEvents = False
            DestRange(x).Resize(UBound(Tab_Result, 2) + 1, 3) = WorksheetFunction.Transpose(Tab_Result)
            Application.EnableEvents = True
        End If
    Next
 
    'On verifie qu'il y a des resultats sinon on vide tout et on quitte
    If bVide Then
        MsgBox "Aucune permutation ne répond à votre critère de somme (" & Cible & ")"
        Application.EnableEvents = False
        [Results].Cells.ClearContents
        Application.EnableEvents = True
        Exit Sub
    End If
 
    Application.ScreenUpdating = True
 
    If cNbM < NbM Then
      MsgBox "Les permutations " & cNbM + 1 & "-uplets à " & NbM & "-uplets répondant à votre critère de somme (" & Cible & ") n'ont pas été calculés car plus de 65000 possibilités."
    End If
 
End Sub

A++
Qwaz

**Masamunai** · 18/03/2010, 19h47

Bonsoir Qwaz,

Le passage en double a résolu le problème, Merci !!

Perso je n'ai toujours pas compris pourquoi ce passage est nécessaire o.O
Apparemment, ces décimales parasites étaient loin de la limite de chiffres après la virgule du type Single non ?

Sinon après toutes ces péripéties, je crois je peux enfin cliquer sur Résolu

Encore merci à Qwaz et le forum Developper.net.

Masa

**Qwazerty** · 18/03/2010, 20h04

Salut

Apparemment, ces décimales parasites étaient loin de la limite de chiffres après la virgule du type Single non ?

En effet je n'ai pas bien saisi non plus a vrai dire, on doit repousser l'erreur de calcul tellement loin avec le Double, qu'il n'est plus possible de l'afficher...
A++
Qwaz

Simplification de boucles FOR avec concaténation ? [Toutes versions]

Macros et VBA Excel

Discussions similaires

Partager

Partager