Détermination de courbe tendance polynomiale

**Nicoyong** · 31/01/2022, 18h11

Bonjour la communauté.
Je viens solliciter votre aide car je voudrais manipuler par macro des courbes de tendances polynomiales.
Voilà où j'en suis je récupère mon nuage de points dans une variable tableau à deux dimensions

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
n = 8
ReDim Mesures(n, 2)
If Cells(34, 16).Value <> "" Then
        j = 34
    Else
        j = 36
    End If
 
    For i = 0 To n - 1 Step 1 
        Mesures(i, 0) = Cells(j, 3).Value  'valeur X
        Mesures(i, 1) = Cells(j, 16).Value 'valeur Y
        j = j + 2 
    Next

Cela fonctionne très bien. Là où je bloque c'est quand j'essaye de convertir les formules Excel suivantes en macro

Polynomiale : y = ax2+bx+c (degré 2)
a = INDEX(DROITEREG(Données_Y;Données_X^{1.2};1;1);1;1)
b = INDEX(DROITEREG(Données_Y;Données_X^{1.2};1;1);1;2)
c = INDEX(DROITEREG(Données_Y;Données_X^{1.2};1;1);1;3)
r² = INDEX(DROITEREG(Données_Y;Données_X^{1.2};1;1);3;1)

Je pense qu'il n'y a rien de compliqué mais comprenant déjà pas tout à fait les arguments de ces formules je n'arrive pas à les convertir en code VBA. Je vous remercie d'avance de l'aide que vous pouvez m'apporter.

**jurassic pork** · 01/02/2022, 07h28

hello,
tu peux essayer quelque chose comme ceci (testé avec Excel 2016) :

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
Sub CalculEquation()
Dim a, b, c, i, r², x, xsq, y
Dim polynome
'ax²+bx+c
x = Range("Données_X")
' on construit un tableau à 2 dimensions x et x²
xsq = x
ReDim Preserve xsq(1 To UBound(xsq), 1 To 2)
'on calcule x au carré
For i = 1 To UBound(xsq)
    xsq(i, 2) = xsq(i, 1) * xsq(i, 1)
Next i
y = Range("Données_Y")
polynome = Application.WorksheetFunction.LinEst(y, xsq, True, True)
a = polynome(1, 1) 'a
b = polynome(1, 2) 'b
c = polynome(1, 3) 'c
r² = polynome(3, 1) 'r²
Debug.Print "a = " & a
Debug.Print "b = " & b
Debug.Print "c = " & c
Debug.Print "r² = " & r²
End Sub

Feuille de départ :

Nom : ExcelPolynome.PNG
Affichages : 917
Taille : 41,8 Ko

Résultat :

a = -0,388131313131313
b = 4,26944444444444
c = -3,34555555555555
r² = 0,924972341303924

Classeur en pièce jointe.

Ami calmant, J.P

**Nicoyong** · 02/02/2022, 19h56

Bonjour et merci à toi Jurassic pork. Cela fonctionne très bien pour moi, il y a pas mal de choses dans le code que je n'ai pas compris il va falloir que j'étudie ça de plus près mais encore un tout gros merci

**Nicoyong** · 04/02/2022, 11h50

Bonjour, j'espère que vous suivez toujours cette discussion. Je n'arrive pas à intégrer votre code à mes besoins. Je rencontre des problèmes à identifier de quel type sont les variables. Je suppose que je ne les utilise pas correctement du coup et je n'arrive pas à redimensionner la matrice xsq. Voici mon début de code je vous remercie pour l'attention portée à ce poste.

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
Sub corection_ipi()
'-----Déclaration variable-----
    Dim x() As Double
    Dim y() As Double
    Dim xsq() As Double
    Dim polynome
    Dim Da As Double
    Dim Db As Double
    Dim i As Single
    Dim j As Single
    Dim n As Single
    Dim r² As Double
    Dim LimiteR² As Double
'-----------------------------
 
'-----Supretion des anciennes valeurs-----
    Cells(23, 14).Value = ""
'-----------------------------
 
If Cells(26, 1).Value = "" Or Cells(34, 16).Value = "" Or Cells(36, 16).Value = "" Or Cells(38, 16).Value = "" Or Cells(40, 16).Value = "" Or Cells(42, 16).Value = "" Or Cells(44, 16).Value = "" Then Exit Sub 'S'il n'y l'anneau n'a pas été sélectionné ou pas de valeur pour les enfoncements à 1. 25 à 7.5 la macro s'arrêtant
 
'-----Configuration des variables-----
    limitR² = 0.99 'Détermine la limite acceptable de R²
    j = 34
'-----------------------------
 
'-----Récupération des données-----
    Debug.Print "Données recuper" & Chr(10) & "x   =   y"
    For i = 0 To 7 Step 1 'Boucle permettant de récupérer les valeurs
        If Cells(j, 16).Value <> "" Then
            ReDim Preserve x(i + 1)
            ReDim Preserve y(i + 1)
            x(i) = Cells(j, 3).Value
            y(i) = Cells(j, 16).Value
            j = j + 2
            Debug.Print x(i) & " = " & y(i)
        End If
    Next i
'-----------------------------
 
'-----Analyse & ajustement la courbe du ²-----
    xsq = x
    ReDim Preserve xsq(1 To UBound(xsq), 1 To 2)
    'on calcule x au carré
    For i = 1 To UBound(xsq)
        xsq(i, 2) = xsq(i, 1) * xsq(i, 1)
    Next i
    polynome = Application.WorksheetFunction.LinEst(y, xsq, True, True)
    ............

**jurassic pork** · 04/02/2022, 13h40

hello,
que se passe-t-il ? Peux-tu mettre un classeur avec tes données d'entrée dedans si ce n'est pas confidentiel ?
Ami calmant, J.P

**Nicoyong** · 06/02/2022, 09h34

Bonjour, ci-joint un extrait de mon tableau en vous remerciant d'avance. Sondage VDevelopeur2.xls

**Nicoyong** · 07/02/2022, 11h26

Bonjour,
après pas mal de recherche ce matin je commence à cerner mon problème, il s'agit des variables tableaux. Je n'arrive pas à comprendre comment fonctionnent vos variables.

1 Je n'arrive pas à charger les variables X&Y sachant qu'elles sont écrites une ligne sur deux. De plus il s'agit de mesures physiques donc il peut manquer certaines valeurs (y).

2 Une fois cette étape faite je calcule mon polynôme et si mon R² n'est pas suffisamment bon je supprime un couple de valeur, le tout premier de la matrice si X est égal à 0,625 autrement je supprime le dernier couple de la matrice. Je vérifie de nouveau R² et recommence l'opération jusqu'à avoir un R² convenable, s'il me reste que cinq valeurs ou moins j'ai une alerte.

Je vous remercie encore de votre aide.

**jurassic pork** · 07/02/2022, 11h40

hello,
si c'est le début de ton programme qui est en commentaire qui ne fonctionne pas, je l'ai corrigé. Voici le code :

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
Sub correction_ipi()
'-----Déclaration variable-----
    Dim x()
    Dim y() As Double
    Dim xsq
    Dim polynome
    Dim yc(4)
    Dim Da As Double
    Dim Db As Double
    Dim Cor As Double
    Dim i As Single
    Dim j As Single
    Dim n As Single
    Dim r² As Double
    Dim LimiteR² As Double
'-----------------------------
 
 
'-----Suppression des anciennes valeurs-----
    Cells(23, 14).Value = ""
    Cells(26, 30).Value = ""
    Cells(28, 30).Value = ""
'-----------------------------
 
 
If Cells(26, 1).Value = "" Or Cells(34, 16).Value = "" Or Cells(36, 16).Value = "" Or Cells(38, 16).Value = "" Or Cells(40, 16).Value = "" Or Cells(42, 16).Value = "" Or Cells(44, 16).Value = "" Then Exit Sub 'S'il n'y l'anneau n'a pas été sélectionné ou pas de valeur pour les enfoncements à 1. 25 à 7.5 la macro s'arrêtant
 
 
'-----Configuration des variables-----
    limitR² = 0.99 'Détermine la limite acceptable de R²
    j = 34
'-----------------------------
 
 
'-----Récupération des données-----
    Debug.Print "Données récupérées" & Chr(10) & "x   =   y"
    Dim nbValeurs
    nbValeurs = 8
    ReDim x(1 To nbValeurs, 1 To 1)
    ReDim y(nbValeurs)
    For i = 1 To nbValeurs Step 1 'Boucle permettant de récupérer les valeurs
        If Cells(j, 16).Value <> "" Then
            x(i, 1) = Cells(j, 3).Value
            y(i) = Cells(j, 16).Value
            j = j + 2
            Debug.Print x(i, 1) & " = " & y(i)
        End If
    Next i
'-----------------------------
 
 
'-----Analyse & ajustement la courbe du ²-----
 
    xsq = x
    ReDim Preserve xsq(1 To UBound(xsq), 1 To 2)
 
    'on calcule x au carré
    For i = 1 To UBound(xsq)
        xsq(i, 2) = xsq(i, 1) * xsq(i, 1)
    Next i

j'ai modifié la façon de gérer x et y (allocation des tableaux en fonction du nombre de valeurs ).

Ami calmant, J.P

**Nicoyong** · 07/02/2022, 12h19

Merci de votre réponse, cependant j'obtiens toujours une erreur sur la ligne :

Code :

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

polynome = Application.WorksheetFunction.LinEst(y, xsq, True, True)

Erreur d'exécution '1004': Impossible de lire la propriété LinEST de la classe WorksheetFuction

Question supplémentaire.
J'ai beaucoup de mal à comprendre la fonction ReDim & ReDim Preserve
est-il possible de supprimer complètement la dernière ligne des matrices y & xsq avec cette fonction ?

**jurassic pork** · 07/02/2022, 12h53

Envoyé par Nicoyong

Merci de votre réponse, cependant j'obtiens toujours une erreur sur la ligne :

Code :

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

polynome = Application.WorksheetFunction.LinEst(y, xsq, True, True)

Erreur d'exécution '1004': Impossible de lire la propriété LinEST de la classe WorksheetFuction

j'ai trouvé l'erreur : c'est y qui était défini en 1 dimension alors qu'il fallait qu'il soit définit en 2 dimensions :

Code :

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

ReDim y(1 To nbValeurs, 1 To 1)

Qu'est-ce que cela veut dire --> y est un tableau à 2 dimensions la première dimension à 8 éléments dont le premier à comme indice 1 (pas 0) et la deuxième dimension à 1 élément d'indice 1
Linest attend ce genre de tableau (à 2 dimensions) pour fonctionner.
Sinon regarder le tutoriel de Silkyroad Utiliser les variables tableaux en VBA Excel
Pour y voir plus clair ajouter des espions sur les variables tableaux dans le débogueur VBA ( on voit comment fonctionnent les tableaux avec leurs indices)
Code qui fonctionne chez moi :

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
 Sub correction_ipi()'-----Déclaration variable-----
    Dim x
    Dim y
    Dim xsq
    Dim polynome
    Dim yc(4)
    Dim Da As Double
    Dim Db As Double
    Dim Cor As Double
    Dim i As Single
    Dim j As Single
    Dim n As Single
    Dim r² As Double
    Dim LimiteR² As Double
'-----------------------------
 
 
'-----Suppression des anciennes valeurs-----
    Cells(23, 14).Value = ""
    Cells(26, 30).Value = ""
    Cells(28, 30).Value = ""
'-----------------------------
 
 
If Cells(26, 1).Value = "" Or Cells(34, 16).Value = "" Or Cells(36, 16).Value = "" Or Cells(38, 16).Value = "" Or Cells(40, 16).Value = "" Or Cells(42, 16).Value = "" Or Cells(44, 16).Value = "" Then Exit Sub 'S'il n'y l'anneau n'a pas été sélectionné ou pas de valeur pour les enfoncements à 1. 25 à 7.5 la macro s'arrêtant
 
 
'-----Configuration des variables-----
    limitR² = 0.99 'Détermine la limite acceptable de R²
    j = 34
'-----------------------------
 
 
'-----Récupération des données-----
    Debug.Print "Données récupérées" & Chr(10) & "x   =   y"
    Dim nbValeurs
    nbValeurs = 8
    ReDim x(1 To nbValeurs, 1 To 1)
    ReDim y(1 To nbValeurs, 1 To 1)
    For i = 1 To nbValeurs Step 1 'Boucle permettant de récupérer les valeurs
        If Cells(j, 16).Value <> "" Then
            x(i, 1) = Cells(j, 3).Value
            y(i) = Cells(j, 16).Value
            j = j + 2
            Debug.Print x(i, 1) & " = " & y(i)
        End If
    Next i
'-----------------------------
 
 
'-----Analyse & ajustement la courbe du ²-----
 
    xsq = x
    ReDim Preserve xsq(1 To UBound(xsq), 1 To 2)
 
    'on calcule x au carré
    For i = 1 To UBound(xsq)
        xsq(i, 2) = xsq(i, 1) * xsq(i, 1)
    Next i
 
polynome = Application.WorksheetFunction.LinEst(y, xsq, True, True)
a = polynome(1, 1) 'a
b = polynome(1, 2) 'b
c = polynome(1, 3) 'c
r² = polynome(3, 1) 'r²
Debug.Print "a = " & Round(a, 10)
Debug.Print "b = " & Round(b, 10)
Debug.Print "c = " & Round(c, 10)
Debug.Print "r² = " & Round(r², 10)

**Nicoyong** · 07/02/2022, 13h31

Je vous remercie de votre réponse cela fonctionne.

Détermination de courbe tendance polynomiale [XL-2003]

Macros et VBA Excel

Discussions similaires

Partager

Partager