Macro trop longue

Bonjour à tous,

Après quelques heures de recherches et d'essai j'essaye d'optimiser ma macro qui est bien trop longue

Après une optimisation qui l'a fait passer de 4h23 à 1min43 en coupant massivement les redondances ou les calculs inutiles je suis aujourd'hui bloquer et sans solution.

Je vais essayé d'être le plus explicite possible sur le fichier...

Ils s'agit d'un jeu de 24 échantillons comportant systématique une valeur de 0 à 400.

A la vu des échantillons je suis persuader qu'il existe une corrélation entre le dosage qui lui est associé et le signal que j'ai récupéré

c'est pourquoi j'essaye de trouver la formule qui me permettra d'estimer avec un faible taux d'erreur, moins de 10% espéré, je suis actuellement vers les 20%.

Le modèle utilisé était une formule de type A/B avec A et B variable de 0 à 400 pour le moment ca va, la macro s'excute en moins de 2min pour faire les 400x400 possibilité...

Cependant le temps d'execution de la macro s'allonge très vite si je veux passer avec une variable supplémentaire le 400x400x200 me fait passer à 2h20 environ.... sachant que je souhaite tester jusqu'à 6 variables type x = A/B + C/D + E/F.

J'ai ajouté des conditionnelle pour essayé d'allegé la macro lors d'écriture de ligne pour ne garder que ce qui m'intéresse...

La macro ici ne fait que changer la valeur les variables et ecrire le résultats si les conditions sont remplites.

Le fichier comporte un ensemble de formule "recherche" pour renouveller la valeur de 24 échantillons par variables...

j'ai essayé par macro mais la formule "recherche" prennait moins de temps (très significativement).

J'ai essayé (pour la premiere fois) le tab(x,y) mais sans succès également ou au mieux équivalent à ce que la formule "recherche" fait.

J'ai ajouté quelques cellules que je parametres pour définir les bornes (de 0 à 400) de mes variables et le pas que je souhaite testé pour essaye, a defaut de pouvoir toutes les faires, dans un délai raisonnable...

Bref il sera peut-être plus simple de regarder le fichier... car je peut-être étais bien moins explicite que je le pense ou qu'une lecture simple du fichier

Voici la macro (que vous retrouverait dans le fichier)

Sub MultiMode() '
Cells(12, 13) = Now
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
y = Cells(Rows.Count, 1).End(xlUp).Row + 1

a = Cells(14, 3)
aa = Cells(14, 4)
aaa = Cells(14, 5)
b = Cells(15, 3)
bb = Cells(15, 4)
bbb = Cells(15, 5)
c = Cells(16, 3)
cc = Cells(16, 4)
ccc = Cells(16, 5)
d = Cells(14, 7)
dd = Cells(14, 8)
ddd = Cells(14, 9)
e = Cells(15, 7)
ee = Cells(15, 8)
eee = Cells(15, 9)
f = Cells(16, 7)
ff = Cells(16, 8)
fff = Cells(16, 9)

For ffff = f To ff Step fff
Cells(7, 1) = ffff
For eeee = e To ee Step eee
Cells(6, 1) = eeee
For dddd = d To dd Step ddd
Cells(5, 1) = dddd
For cccc = c To cc Step ccc
Cells(4, 1) = cccc
    For bbbb = b To bb Step bbb
    Cells(3, 1) = bbbb
        For aaaa = a To aa Step aaa
        Cells(2, 1) = aaaa
        Range("A2:Y12").Calculate 'A rédéfinir si ajout variable
        If Cells(12, 18) = "oui" Then
        If Cells(12, 11) >= Cells(12, 12) Then
        Rows(y) = Rows(11).Value
        y = y + 1
        End If
        Else
        Rows(y) = Rows(11).Value
        y = y + 1
        End If
        If y = 500 Then
        GoTo Saut
        End If
                Next aaaa

        If Cells(13, 2) = "non" Then
        a = a + aaa
        End If
        Next bbbb
     y = Cells(Rows.Count, 1).End(xlUp).Row + 1
     a = Cells(14, 3)
     b = Cells(15, 3)
 Next cccc
     y = Cells(Rows.Count, 1).End(xlUp).Row + 1
     a = Cells(14, 3)
     b = Cells(15, 3)
     c = Cells(16, 3)
Next dddd
    y = Cells(Rows.Count, 1).End(xlUp).Row + 1
    a = Cells(14, 3)
    b = Cells(15, 3)
    c = Cells(16, 3)
    d = Cells(14, 7)
Next eeee
    y = Cells(Rows.Count, 1).End(xlUp).Row + 1
    a = Cells(14, 3)
    b = Cells(15, 3)
    c = Cells(16, 3)
    d = Cells(14, 7)
    e = Cells(15, 7)
Next ffff

Application.Calculation = xlCalculationAutomatic
Cells(12, 14) = Now
Cells(12, 15) = Cells(12, 14) - Cells(12, 13)
Application.ScreenUpdating = True
MsgBox "Opération terminée"
Exit Sub
Saut:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Affinez les bornes sélectives"
End Sub

D'avance merci pour votre temps et votre aide,

Bien à vous.

NB : je suis assez "débutant" cela fait 1 an que je bricole, grâce au forum et des heures essais, des petites macros d'automatisation d'extraction de données.

24 echantillons de 0 à 400?

Votre graphique va de 0 à 10

A la vu des échantillons?

qu'appelez vous échantillon?

Associé à un signal?

Ou est ce signal?

Signal que j'ai récupéré?

Peut-on l'avoir?

Expliquez clairement ce que vous voulez atteindre avec vos calculs

merci

Merci pour votre retour, je craignais de ne pas etre assez explicite et c'est le cas je vais essayé a nouveau sans preuve de réussite :/

C'est ca il y a 24 échantillons (biologique) (de colonne B à Y) dont le signal (lumineux) de 401 mesures dinstingues donnant chacune 1 valeurs associées dans la feuille "Data"

C'est 24 échantillons ont donné une valeurs analytiques (analyse chimique) retranscrite en ligne 9 (feuille "Générateur") avec respectivement les colonne B à Y associés.

Je veux trouvé via une formule la meilleur combinaison permettant de détermine une droite de régression qui fittera le mieux avec les données analytiques. Et Ainsi pouvoir prédire une valeurs proche de la mesure analytique (qui est tres fastidieuse et longue)

Sur la feuille Générateur

A2:A7 representent les variables A,B,C,D,E,F

Que je fait varié la valeurs par macro avec les bornes qui sont défini en B13:I16

et par exemple si je tire le f(A/B) = Valeur estimée, avec A = 220 et B = 211 cela me tire une droite de regression qui me permet d'avoir une estimation pour chaque échantillon dont 92% (22 échantillons/24) sont estimés avec une erreur de 20%

le graphique plot le rapport d'une formule lambda (type A/B, que je souhaite faire evoluer) avec les valeurs mesuré(analytique : point rouge) donnant la regression linéaire (courbe grasse) et ses 2 équivalents avec une marges d'erreur défini en G12 et I12, je crois que sur le fichier envoyé c'est 20%.

Ce sont les données brutes je n'ai que ça comme support

L'ensemble de la macro marche à "merveille" hormis son temps car

faire varié systématique A et B de 0 à 400 indépendamment represente 160000 itérations me prennent moins de 2min a executé mais si je veux complexifier la formule avec 3 variables c'est 400*400*400 qui prendrait plus de 8h ou plus je n'ai jaimais osé la lancer. et j'aimerais faire evoluer cette formule avec 6 variables donc 400*400*400*400*400*400 itérations... donc impossible a réaliser en l'état.

J'espère avoir était plus clair dans ma demande :/

Merci pour votre aide

Le sujet est trop ardu pour moi!

je laisse la main à plus fort

juste déclarer les variables de boucles DIM a as integer

vrai de a à aaaa, b à bbbb etc....

et présenter le code comme ci-joint

bon courage

J'ai basculé l'intégralité du calcul sur VBA enfin presque car je n'arrive pas a passer uniquement par du tableau :/

L'equivalent pente et ordonnée à l'origine que j'ai du gardé sous forme de cellule

Mais maintenant je n'arrive plus à Boucler T.T

Sub MetaFormula()
Dim sh1, sh2 As Worksheet
Set sh1 = ThisWorkbook.Sheets("Data")
Set sh2 = ThisWorkbook.Sheets("Générateur")

sh2.Cells(12, 13) = Now
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
y = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1

Dim Tab0() As Double
ReDim Tab0(1 To 24)
For i = 2 To 25
Tab0(i - 1) = sh2.Cells(9, i)
Next i

Dim a, aa, aaa, aaaa As Double
Dim b, bb, bbb, bbbb As Double
Dim c, cc, ccc, cccc As Double
Dim d, dd, ddd, dddd As Double
Dim e, ee, eee, eeee As Double
Dim f, ff, fff, ffff As Double

a = Cells(14, 3)
aa = Cells(14, 4)
aaa = Cells(14, 5)
b = Cells(15, 3)
bb = Cells(15, 4)
bbb = Cells(15, 5)
c = Cells(16, 3)
cc = Cells(16, 4)
ccc = Cells(16, 5)
d = Cells(14, 7)
dd = Cells(14, 8)
ddd = Cells(14, 9)
e = Cells(15, 7)
ee = Cells(15, 8)
eee = Cells(15, 9)
f = Cells(16, 7)
ff = Cells(16, 8)
fff = Cells(16, 9)

For ffff = f To ff Step fff
For eeee = e To ee Step eee
For dddd = d To dd Step ddd
For cccc = c To cc Step ccc
For bbbb = b To bb Step bbb
For aaaa = a To aa Step aaa

Dim Tab1() As Double
ReDim Tab1(1 To 24)
For i = 2 To 25
Tab1(i - 1) = (sh1.Cells(aaaa + 1, i) - sh1.Cells(bbbb + 1, i)) / sh1.Cells(cccc + 1, i)
Next i

Cells(12, 18) = Application.LinEst(Tab0, Tab1)
Cells(12, 19) = WorksheetFunction.Intercept(Tab0, Tab1)

Dim Tab2() As Double
Dim Atteint As Integer
ReDim Tab2(1 To 24)
ppp = 0
For i = 2 To 25
Tab2(i - 1) = (sh2.Cells(12, 18) * Tab1(i - 1) + sh2.Cells(12, 19))
Next i

For i = 1 To 24
If Tab2(i) / Tab0(i) >= sh2.Cells(12, 7) And Tab2(i) / Tab0(i) <= sh2.Cells(12, 9) Then
ppp = ppp + 1
End If
Next i

If ppp > sh2.Cells(12, 12) Then
For i = 2 To 25
Cells(y, i) = Tab2(i - 1) / Tab0(i - 1)
Cells(y, 1) = aaaa & "-" & bbbb
Next i
End If

Next aaaa
Next bbbb
Next cccc
Next dddd
Next eeee
Next ffff

Cells(16, 1) = y - 16

Application.Calculation = xlCalculationAutomatic
sh2.Cells(12, 14) = Now
sh2.Cells(12, 15) = sh2.Cells(12, 14) - sh2.Cells(12, 13)
Application.ScreenUpdating = True
MsgBox "Opération terminée"
End Sub