Optimisation d'une fonction à plusieurs variables

Version imprimable

Voir 40 message(s) de cette discussion en une page

30/04/2009, 10h28
kokoVBA

1 pièce(s) jointe(s)

Re,
voilà j'ai mis en PJ un fichier d'exemple :
en feuil0 on a la fonction qui génère le résultat.
en feuil1 on a les valeurs possibles pour chaque hypothèse.
L'idée est de trouver le nuplet qui minimise la fonction et le rentrer dans la feuil0.
Encore une fois c'est une fonction quelconque pour l'exemple.
Ce qui serait pas mal c'est que la macro prenne en compte le fait que le nombre d'hypothèses peut changer (dans mon exemple on a 5 hypothèses) afin de générer dans la feuil0 le bon nuplet (ici un quintuplet).
J'espère avoir été assez clair dans ma question.
A+
30/04/2009, 10h38
Krovax

Je vais pas pouvoir regarder ca aujourd'hui, ce soir peut être sinon demain. Mais essaye de mettre le résultat de ta fonction en première colonne de la ligne 1 et 2 (les fonctions excel pourrais peut être suffire)

Ensuite le code devrais rouler tout seul et ne te garder que le plus petit n-uplet.

1 pièce(s) jointe(s)

Bonjour à tous ceux qui s'intéressent à ce topic,

J'ai complété ta macro (cf. ci-dessous + pièce jointe). Tu peux me dire si c'est bien ça que tu veux ? (2 mises en garde : le dernier résultat affiché dans la case 'résultat' ne correspond pas au minimum ; le n-upplet réalisant le minimum affiché est le dernier n-upplet étudié réalisant le minimum
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 Sub modu() Dim i As Long Dim j As Long Dim k As Integer Dim n As Integer Dim vari() As Double Dim fl As Integer Dim val As Integer Dim nbrligneparonglet As Long Dim resultatminimum As Double 'n variables 'k valeurs n = 5 k = 4 nbrligneparonglet = 400 'on met suffisament d'onglets If Sheets.Count <= k ^ n \ nbrligneparonglet + 2 Then Do While Sheets.Count <= k ^ n \ nbrligneparonglet + 2 Sheets.Add after:=Worksheets(Worksheets.Count) Loop End If 'on remplit le tableau avec les valeurs du n-uplet ReDim vari(1 To n, 1 To k) For i = 1 To n For j = 1 To k vari(i, j) = Feuil1.Cells(j + 1, i + 1) Next j Next i 'on écrit les n-uplets dans les différents onglets et on teste chaque n-upplet pour avoir le minimum resultatminimum = CDbl(Sheets(1).Cells(10, 3).Text) For i = 0 To k ^ n - 1 For j = 0 To n - 1 fl = 2 + (i \ nbrligneparonglet + 1) val = (i \ (k ^ j)) Mod (k) Sheets(fl).Cells(i + 1 - (fl - 3) * nbrligneparonglet, j + 1).Value = vari(j + 1, val + 1) Sheets(1).Cells(6, 2 + j).Value = Sheets(fl).Cells(i + 1 - (fl - 3) * nbrligneparonglet, j + 1) Next j If CDbl(Sheets(1).Cells(10, 3).Text) < resultatminimum Then For j = 0 To n - 1 Sheets(1).Cells(16, 2 + j).Value = Sheets(1).Cells(6, 2 + j).Value Next j resultatminimum = CDbl(Sheets(1).Cells(10, 3).Text) Else 'indique ici ce que tu veux faire en cas d'égalité par exemple End If Next i End Sub
@ Krovax : double bravo
1) pour avoir trouvé comment extraire proprement les k^n n-upplets d'une matrice [n,k] (je n'avais pas compris que c'était la question initiale de kokoVBA, j'avais juste proposé un algo pr trouver le minimum d'une fonction à 3 variables dont les différentes valeurs sont données dans le tableau, mais même si j'avais compris qu'il fallait d'abord extraire les n-upplets sur des feuilles séparées j'aurais séché :p)
2) pour mettre en avant Fortran, il n'y a que le Fortran qui vaut le coup pour du calcul numérique, notamment de l'optimisation ! moi-même je ne sais coder qu'en VBA et Fortran (+/-...)

@kokoVBA : peux-tu transmettre la version la plus mise-à-jour de ton code histoire que je vois ce que ça donne au final ?

05/05/2009, 09h47
kokoVBA

Bonjour Gautier B.,
effectivement ta version permet d' extraire le n-uplet qui vérifie le min de la fonction. :king:
Maintenant le problème c'est que tu écris les n-uplets dans les onglets et que si n et k sont grands, on sera limités par excel.
La version sur laquelle planche krovax devrait permettre de contourner ce problème en n'écrivant pas les n-uplets mais en les testant un à un et en gardant celui qui vérifie le min.
Merci pour ton apport, je mettrai la dernière version de la macro sur le forum une fois qu'on sera allés au bout du sujet ;)
A+

1 pièce(s) jointe(s)

Que penses-tu du code suivant ?

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
 
Sub modu2()
Dim i As Long
Dim j As Long
Dim k As Integer
Dim n As Integer
Dim vari() As Double
Dim val As Integer
Dim resultatminimum As Double
'n variables
'k valeurs
n = 5
k = 4
 
'on remplit un tableau de forme similaire au tableau dans "feuil1"
ReDim vari(1 To n, 1 To k)
For i = 1 To n
    For j = 1 To k
        vari(i, j) = Feuil1.Cells(j + 1, i + 1)
    Next j
Next i
 
'Chaque n-uplet généré est directement écrit sur la ligne de "feuil0"
'et on teste chaque n-uplet 2 à 2 pour avoir le minimum
resultatminimum = CDbl(Sheets(1).Cells(10, 3).Text)
For i = 0 To k ^ n - 1
    For j = 0 To n - 1
        val = (i \ (k ^ j)) Mod (k)
        Sheets(1).Cells(6, 2 + j).Value = vari(j + 1, val + 1)
    Next j
    If CDbl(Sheets(1).Cells(10, 3).Text) < resultatminimum Then
        For j = 0 To n - 1
            Sheets(1).Cells(16, 2 + j).Value = Sheets(1).Cells(6, 2 + j).Value
        Next j
        resultatminimum = CDbl(Sheets(1).Cells(10, 3).Text)
    Else
        'indique ici ce que tu veux faire en cas d'égalité par exemple
    End If
Next i
Erase vari 'on libère la mémoire
End Sub

Je te mets en PJ le fichier comportant cette macro (module 2, qui s'éxécute avec le CommandButton2).
En espérant que ça réponde à ta question,
Gautier

Bonjour Gautier B., bonjour à tous,

Gautier B. je n'ai pas encore testé ton code, travaillant moi-même dessus.
Je vous propose une version de la macro qui permet de ne pas écrire les n-uplets dans les onglets et donc de n'être limité que par le temps, c'est à dire par le nombre d'hypothèses et de valeurs à tester, et par la vitesse de votre processeur :mouarf:

Ce code peut encore être amélioré mais comme il répond à la question de départ je vais enfin pouvoir cliquer sur :resolu:

le code :

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
Sub testhyp()
Dim i As Long
Dim j As Long
Dim k As Integer
Dim n As Integer
Dim vari() As Double
Dim fl As Integer
Dim val As Integer
Dim nbrligneparonglet As Long
Dim t_deb As Single, t_fin As Single, tpass As Single
Dim resultatminimum As Double
 
 
'n variables
'k valeurs
Sheets("Hyp").Select
k = Range("b65536").End(xlUp).Row - 1
 
'k Valeur
n = Range("IV2").End(xlToLeft).Column - 1
 
 
t_deb = Timer
 
'on remplit le tableau avec les valeurs du n-uplet
ReDim vari(1 To n, 1 To k)
For i = 1 To n
    For j = 1 To k
        vari(i, j) = Feuil1.Cells(j + 1, i + 1)
    Next j
Next i
 
'on écrit les n-uplets dans les différents onglets et on teste chaque n-upplet pour avoir le minimum
resultatminimum = Sheets(1).Cells(10, 3).Value
For i = 0 To k ^ n - 1
    For j = 0 To n - 1
        val = (i \ (k ^ j)) Mod (k)
        Sheets(3).Cells(1, j + 1).Value = vari(j + 1, val + 1)
        Sheets(1).Cells(6, 2 + j).Value = Sheets(3).Cells(1, j + 1)
    Next j
    If Sheets(1).Cells(10, 3).Value < resultatminimum Then
        For j = 0 To n - 1
            Sheets(1).Cells(16, 2 + j).Value = Sheets(1).Cells(6, 2 + j).Value
        Next j
        resultatminimum = Sheets(1).Cells(10, 3).Value
    Else
        'indique ici ce que tu veux faire en cas d'égalité par exemple
    End If
Next i
 
t_fin = Timer
tpass = CSng(Round(t_fin - t_deb, 2))
 
MsgBox "Il faut " & tpass & " s pour tester les hypothèses"
 
End Sub

Un grand merci à tous ceux qui ont apporté leur aide, avec une mention spéciale à Krovax pour sa description des n-uplets! :king:

Voir 40 message(s) de cette discussion en une page