XL 2016 Correction VBA récupération terme fonction polynomiale

[Grimalkinc]

Bonjour,

J'ai récupérer cette fonction sur une vieux site et pas moyen de la déboguer, j'utilise Excel 2016.

Function PolyA(ByVal MatX As Range, ByVal MatY As Range, ByVal N As Long, Optional ByVal I As Variant = 1)
'Calcul du coefficient "Ci" de l'équation polynomiale de degré n
'calculé par les moindres carrés des points donnés Pt(xi,yi)
'Soit xi = matx et yi = maty
'Y = C1*X^n + Ci*X^(n-1) + ... + Cn.

'Traitement de l'index
I = CLng(I)

'Résolution matricielle

'Tailles matrices
Dim l As Long, L2 As Long, C As Long, C2 As Long
l = MatX.Rows.Count
L2 = MatY.Rows.Count
C = MatX.Columns.Count
C2 = MatY.Columns.Count

'Erreur de taille
If C > 1 Or C2 > 1 Then PolyA = "#COLONNE!": Exit Function
If l <> L2 Then PolyA = "#LIGNE!": Exit Function
If l < N - 1 Then PolyA = "#DEGRE!": Exit Function
If I - 1 > N Then PolyA = "#INDICE!": Exit Function

'calcul la matrice rectangulaire en X
ReDim coefa(1 To l, 1 To N + 1)
Dim t As Long, tt As Long, X As Double
For t = 1 To l
X = MatX.Cells(t)
For tt = 1 To N + 1
coefa(t, tt) = X ^ (N + 1 - tt)
Next tt, t

'matrice Y
ReDim coefb(l)
For t = 1 To l
coefb(t) = MatY.Cells(t)
Next t

'Redéfinition matricelle carré selon
'la méthode des moindres carrés
'Matrice X
ReDim MatA(1 To N + 1, 1 To N + 1)
Dim m As Long, S As Double
For tt = 1 To N + 1
For m = 1 To N + 1
S = 0
For t = 1 To l
S = S + coefa(t, tt) * coefa(t, m)
Next t
MatA(tt, m) = S
Next m, tt

'Redéfinition matricielle carré
'Matrice Y
ReDim MatB(N + 1, 1)
For tt = 1 To N + 1
S = 0
For t = 1 To l
S = S + coefa(t, tt) * coefb(t)
Next t
MatB(tt, 1) = S
Next tt

'inverse matA et garde la ligne i
ReDim mataa(1, N + 1)
For t = 1 To N + 1
mataa(1, t) = InverseTabMat(MatA(), I, t)
Next t

'produit deux lignes
PolyA = ProduitTabMat(mataa(), MatB(), 1, 1)

End Function


Si quelqu'un trouve je suis preneur !

Merci d'avance

 

[sylvanu]

Bonjour Grimalkinc, et bienvenu sur XLD,
1- Il est plus lisible et plus digeste de mettre le code en utilisant la balise </> ( à droite de l'icone GIF )
2- Un petit fichier test représentatif simplifierait bien les choses, d'une part pour nous éviter de créer un fichier bidon qui ne correspondra pas au votre, d'autre part parce que les solutions apportées seront directement transposable dans votre "vrai" fichier.

 

[Dranreb]

Bonjour.
J'ai de vieux modules avec une fonction SolPoly pour calculer ça.
Auriez vous un classeur de données de test ?

 

[Grimalkinc]

Bonjour Grimalkinc, et bienvenu sur XLD,
1- Il est plus lisible et plus digeste de mettre le code en utilisant la balise </> ( à droite de l'icone GIF )
2- Un petit fichier test représentatif simplifierait bien les choses, d'une part pour nous éviter de créer un fichier bidon qui ne correspondra pas au votre, d'autre part parce que les solutions apportées seront directement transposable dans votre "vrai" fichier.

Bonjour,

Merci pour la petite mise au point

voici donc la formule en question

Function PolyA(ByVal MatX As Range, ByVal MatY As Range, ByVal N As Long, Optional ByVal I As Variant = 1)
'Calcul du coefficient "Ci" de l'équation polynomiale de degré n
'calculé par les moindres carrés des points donnés Pt(xi,yi)
'Soit xi = matx et yi = maty
'Y = C1*X^n + Ci*X^(n-1) + ... + Cn.

'Traitement de l'index
I = CLng(I)

'Résolution matricielle

'Tailles matrices
Dim l As Long, L2 As Long, C As Long, C2 As Long
l = MatX.Rows.Count
L2 = MatY.Rows.Count
C = MatX.Columns.Count
C2 = MatY.Columns.Count

'Erreur de taille
If C > 1 Or C2 > 1 Then PolyA = "#COLONNE!": Exit Function
If l <> L2 Then PolyA = "#LIGNE!": Exit Function
If l < N - 1 Then PolyA = "#DEGRE!": Exit Function
If I - 1 > N Then PolyA = "#INDICE!": Exit Function

'calcul la matrice rectangulaire en X
ReDim coefa(1 To l, 1 To N + 1)
Dim t As Long, tt As Long, X As Double
For t = 1 To l
    X = MatX.Cells(t)
For tt = 1 To N + 1
    coefa(t, tt) = X ^ (N + 1 - tt)
Next tt, t

'matrice Y
ReDim coefb(l)
For t = 1 To l
    coefb(t) = MatY.Cells(t)
Next t

'Redéfinition matricelle carré selon
'la méthode des moindres carrés
'Matrice X
ReDim MatA(1 To N + 1, 1 To N + 1)
Dim m As Long, S As Double
For tt = 1 To N + 1
    For m = 1 To N + 1
        S = 0
        For t = 1 To l
            S = S + coefa(t, tt) * coefa(t, m)
        Next t
    MatA(tt, m) = S
Next m, tt

'Redéfinition matricielle carré
'Matrice Y
ReDim MatB(N + 1, 1)
For tt = 1 To N + 1
    S = 0
    For t = 1 To l
        S = S + coefa(t, tt) * coefb(t)
    Next t
    MatB(tt, 1) = S
Next tt

'inverse matA et garde la ligne i
ReDim mataa(1, N + 1)
For t = 1 To N + 1
    mataa(1, t) = InverseTabMat(MatA(), I, t)
Next t

'produit deux lignes
PolyA = ProduitTabMat(mataa(), MatB(), 1, 1)

End Function

Et en pièce jointe le fichier avec mes X et Y correspondant à la courbe sur laquelle je travaille, l'objectif étant de récupérer les coefficients d'un polynôme d'ordre n en automatique.

Merci de votre aide

 

[sylvanu]

Re,
Je pense que quand vous avez récupérer cette fonction, elle n'était pas seule.
Les erreurs se situent sur InverseTabMat et ProduitTabMat qui sont, je pense, deux fonctions manquantes. L'une est l'inversion d'une matrice, l'autre le produit de deux matrices.
Regardez là où vous avez récupéré votre fonction, les deux autres doivent aussi être présentes.

 

[Grimalkinc]

Merci Sylvanu j'ai finalement réussi à débloquer la situation en installant un pack de macro qui était très bien caché sur le site ...

 

[sylvanu]

Pouvez vous donner le site, cela peut servir aux futurs lecteurs.

 

[Dranreb]

Curieuse série quand on reproduit tout sur le graphique.
Jusqu'à 200 environ une décroissance exponentielle ou une fonction conique pourrait être meilleure comme approximation qu'un polynôme