Résoudre équation polynomial 3ème degré sous vba, RacineDegre3(a,b,c,d)?

G

guainflo

XLDnaute Junior
Bonjour,

J'ai vu sur internet qu'il y a une fonction sur vba qui permet de résoudre une équation polynomial du 3ème degré :
RacineDegre3(a,b,c,d)

RESOLUTION D'UNE EQUATION DU TROISIEME DEGRE racine, degré, 3, cardan, équation, Source N°36166 Visual Basic, VB6, VB.NET, VB 2005, VB

Es-ce quelqu'un la connais, comment l'utiliser (mes coefficients se trouvent sur la Feuil1?

Voici mon équation à résoudre : Y = A*X^3 + B*X^2 + C*X + D, elle se trouve dans une boucle, donc je dois la résoudre beaucoup de fois, et comme j'utilise déjà une boucle pour la résoudre (j'augmente X à partir de 0 jusqu'à trouver le bon Y), c'est très long (plusieurs minutes).

Si cette ligne existe, en faisant 0=A*X^3+B*X^2+C*X+(D-Y).
 
Trier par date Trier par votes
G

guainflo

XLDnaute Junior
Re : Résoudre équation polynomial 3ème degré sous vba, RacineDegre3(a,b,c,d)?

En fait je me suis trompé je crois, RacineDegre3(a,b,c,d) est un programme écrit par quelqu'un.

Mais es-ce que vba peut résoudre lui même cette équation, existe t'il une ligne de code pour cela?
 
Vote positif 0 Vote négatif
HIJACK

HIJACK

XLDnaute Junior
Re : Résoudre équation polynomial 3ème degré sous vba, RacineDegre3(a,b,c,d)?

HI!,
Essayer çà:


Code: 
Sub MoindreCarre(X(), Y(), p, C())

    'X : Tableau des abscisses
    
    'y : Tableau des ordonnées
    
    'p : Dégre de la régression
    
    'C : Tableau des coefficients du polynome calcul (doit contenir p+1 termes)
    
    '

    'le polynome genere est de la forme : Y = C(0)+ C(1)*X + C(2)* X^2 + ....
 Dim A(), S() As Double

    'Nombre de points

    'N = 7

    'plage des X

    'X(1) = -3: X(2) = -2: X(3) = 1: X(4) = 2: X(5) = 3: X(6) = 4: X(7) = 5

    'plage des Y

    'Y(1) = 2: Y(2) = 0.5: Y(3) = -1: Y(4) = -1: Y(5) = 0: Y(6) = 2: Y(7) = 4

' Solution : c(2) = 0.2698761, c(1) = -0.304307, c(0) = -1.258357.



'Nombre de points
    
    n = UBound(X)
    
    
    
    ReDim A(1 To p + 1, 1 To p + 1), S(0 To 2 * p), W(1 To p + 1, 1 To 1), Sol(1 To p + 1, 1 To 1)   'dimensions de la matrice du système
    
    
    
    'calcul des Sk
    
    For k = 0 To 2 * p: S(k) = 0
    
      For i = 1 To n
    
        S(k) = S(k) + X(i) ^ k
    
      Next i
    
    Next k
    
    'calcul des Wk
    
    For k = 0 To p: W(k + 1, 1) = 0
    
      For i = 1 To n
    
        W(k + 1, 1) = W(k + 1, 1) + Y(i) * X(i) ^ k
    
      Next i
    
    Next k
    
    'coefficients de la matrice du système
    
    For i = 1 To p + 1
    
      For j = 1 To p + 1
    
       If i = 1 And j = 1 Then A(1, 1) = n Else A(i, j) = S(i + j - 2)
    
      Next j
    
    Next i
    
    
    
    Call MAT_GAUSS(A(), W(), Sol())
    
    For k = 0 To p
    
     C(k + 1) = Sol(k + 1, 1) 'matrice colonne du second membre
    
    Next k
    
    End Sub
    
    
    
    '----------------------------------------------------------------------------------
    
    
    
    Function Solvdeg3(A, B, C, D, X)
    
    'Resolution d'une équation du troisieme degre selon l'algorithme de Cadran
    
    'f(x)= A x^3 + B x^2 + C x +  D = 0
    
    
    
    Dim q, del
    
    
    ReDim X(0 To 2)
    
    vt = -B / (3 * A)
    
    mvt = -vt
    
    p = C / A - B ^ 2 / (3 * A ^ 2)
    
    q = B ^ 3 / (A ^ 3 * 13.5) + (D / A) - B * C / (3 * A ^ 2)
    
    del = (q ^ 2 / 4) + (p ^ 3 / 27)
    
    
    
    If (Abs(p) < 0.000000000001) Then p = 0
    
    If (Abs(del) < 0.000000000001) Then del = 0
    
    
    
    If (del <= 0) Then
    
        If (p <> 0) Then
    
         kos = -q / 2 / Sqr(-p ^ 3 / 27)

         If (Abs(kos) > 1) Then kos = Sgn(kos)
    
        End If
    
        If (Abs(kos) = 1) Then
    
          alpha = -Pi * (kos - 1) / 2
    
        Else
    
          alpha = Acos(kos)
    
        End If
    
        R = Sqr(-p / 3)
    
        For k = 0 To 2
    
          X(k) = 2 * R * Cos((alpha + 2 * k * Pi) / 3) + vt
    
        Next k
    
        Solvdeg3 = 3 '3 solutions  (peut etre 2 double)
    
    Else
    
        R = Sqr(del)
    
        sg = 1
    
        Z = -q / 2 + sg * R
    
        uv1 = Sgn(Z) * Abs(Z) ^ (1 / 3)
    
        
    
        sg = -1
    
        Z = -q / 2 + sg * R
    
        uv2 = Sgn(Z) * Abs(Z) ^ (1 / 3)
        xuni = uv1 + uv2 + vt
    
        For k = 0 To 2
    
          X(k) = xuni
    
        Next k
        Solvdeg3 = 1 '1 solution unique (les 2 autres sont complexes)
    
    End If
    
    

    End Function

Pas testé, sans doute à adapter, tiens nous au courant si ça roule.
Bye
 
Vote positif 0 Vote négatif
G

guainflo

XLDnaute Junior
Re : Résoudre équation polynomial 3ème degré sous vba, RacineDegre3(a,b,c,d)?

Bonjour et merci HIJACK,

Ca marche parfaitement jusqu'à maintenant, voici le code que j'ai tapé pour tester (je ne l'ai pas encore intégré à mon prg) :

J'ai changé la ligne alpha = Acos(kos) par la fonction ArcCos (trouvé sur internet), Acos n'est pas connu de vba apparement (je suis sur excel 2000).



Code: 
Private Sub CommandButton1_Click()
    'Resolution d'une équation du troisieme degre selon l'algorithme de Cadran
    'f(x)= A x^3 + B x^2 + C x +  D = 0
    A = Range("A1")
    B = Range("B1")
    C = Range("C1")
    D = Range("D1")
    Dim q, del
    ReDim X(0 To 2)
    vt = -B / (3 * A)
    mvt = -vt
    p = C / A - B ^ 2 / (3 * A ^ 2)
    q = B ^ 3 / (A ^ 3 * 13.5) + (D / A) - B * C / (3 * A ^ 2)
    del = (q ^ 2 / 4) + (p ^ 3 / 27)
    If (Abs(p) < 0.000000000001) Then p = 0
    If (Abs(del) < 0.000000000001) Then del = 0
    If (del <= 0) Then
        If (p <> 0) Then
            kos = -q / 2 / Sqr(-p ^ 3 / 27)
            If (Abs(kos) > 1) Then kos = Sgn(kos)
        End If
        If (Abs(kos) = 1) Then
          alpha = -PI * (kos - 1) / 2
        Else
          alpha = ArcCos(kos)
        End If
        R = Sqr(-p / 3)
        For k = 0 To 2
          X(k) = 2 * R * Cos((alpha + 2 * k * PI) / 3) + vt
        Next k
        Solvdeg3 = 3 '3 solutions  (peut etre 2 double)
    Else
        R = Sqr(del)
        sg = 1
        Z = -q / 2 + sg * R
        uv1 = Sgn(Z) * Abs(Z) ^ (1 / 3)
        sg = -1
        Z = -q / 2 + sg * R
        uv2 = Sgn(Z) * Abs(Z) ^ (1 / 3)
        xuni = uv1 + uv2 + vt
        For k = 0 To 2
            X(k) = xuni
        Next k
        Solvdeg3 = 1 '1 solution unique (les 2 autres sont complexes)
    End If
    Range("A3") = X(0)
    Range("B3") = X(1)
    Range("C3") = X(2)
End Sub

Function ArcCos(X) As Double
    'Inverse du Cosinus
    If X = 1 Then
        ArcCos = 0
    ElseIf X = -1 Then
        ArcCos = -PI()
    Else
         ArcCos = Atn(-X / Sqr(-X * X + 1)) + PI() / 2
    End If
End Function

Function PI() As Double
    PI = Atn(1) * 4
End Function

Si ca plante, je posterais un message.

Encore merci.
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Résoudre équation polynomial 3ème degré sous vba, RacineDegre3(a,b,c,d)?

Bonjour à tous



À défaut d'une fonction intégrée, une fonction personnalisée en VBA :​
VB: 
Function DEG3b(a#, ByVal b#, c#, d#)
Application.Volatile
Dim p#, q#, r#, s#, rx1#, rx2#, rx3#, ix2#, ix3#
    b = b / a / 3
    p = b * b - c / a / 3
    q = (b * c - d) / a / 2 - b * b * b
    r = q * q
    s = p * p * p
    If Abs(r - s) < 0.00000000000001 Then
        p = Sgn(q) * Abs(q) ^ (1 / 3)
        rx1 = 2 * p
        rx2 = -p
        rx3 = -p
    ElseIf r < s Then
        If r / s >= 1 Then r = 2 * (1 - Sgn(q)) * Atn(1) Else r = Atn(-q / Sqr(s - r)) + 2 * Atn(1)
        rx1 = Sqr(p) * Cos((r + 8 * Atn(1)) / 3) * 2
        rx2 = Sqr(p) * Cos((r - 8 * Atn(1)) / 3) * 2
        rx3 = Sqr(p) * Cos(r / 3) * 2
    Else
        r = Sqr(r - s)
        p = Sgn(q + r) * Abs(q + r) ^ (1 / 3)
        q = Sgn(q - r) * Abs(q - r) ^ (1 / 3)
        rx1 = q + p
        rx2 = -rx1 / 2
        ix2 = Sqr(3) * (q - p) / 2
        rx3 = rx2
        ix3 = -ix2
    End If
    DEG3b = Array(rx1 - b, rx2 - b, ix2, rx3 - b, ix3)
End Function
Exemples d'utilisation dans le fichier joint.​



ROGER2327
#5912

Jeudi 12 Merdre 139 (Saintes Miches, catéchumènes - fête Suprême Quarte)
10 Prairial An CCXX, 6,6955h - faux
2012-W22-2T16:04:09Z
 

Pièces jointes

  • Equation du troisième degré (v3).xlsm
    24.6 KB · Affichages: 811
Vote positif 0 Vote négatif

Discussions similaires

C
  • Question
XL 2013 VBA - Copier coller valeurs uniquement - Macro consolidation
Réponses
1
Affichages
1 K
sylvanu
sylvanu
M
  • Question
XL 2013 Erreur d'exécution 9 ou 13 que je n'arrive pas à résoudre.
2
Réponses
20
Affichages
3 K
massol
M
patouman
  • Question
Probleme de macro complementaire a integrer dans macro existante
Réponses
6
Affichages
1 K
denis
D
J
  • Question
[RESOLU] VBA - error 1004 que je n'arrive pas à corriger
Réponses
8
Affichages
1 K
jeje1712
J
G
  • Question
Résoudre une équation (l'inverse) sur vba, y=f(x), trouver x avec y connu
Réponses
2
Affichages
3 K
pierrejean
pierrejean
R
  • Question
Supp lignes si caractère d'1 plage <> A ou B
Réponses
2
Affichages
962
RoadRunner
R

Membres actuellement en ligne

14 membres et 79 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 214
Messages
2 086 313
Membres
103 175
dernier inscrit
abcc