XL 2016 Détection valeur X de la pente

Quatr_o

XLDnaute Nouveau
Bonjour à tous,

Je sèche, je fais appel à la communauté car je souhaite détecter la valeur en abscisses des pentes des différentes butées par le calcul ou en automatique afin de me faciliter le travail auriez-vous des idées ?
ci-joint la courbe .
merci d'avance de votre aide qui me sera précieuse.

cordialement.
 

Pièces jointes

  • Data v1.xlsx
    252.9 KB · Affichages: 11

Dranreb

XLDnaute Barbatruc
Bon je n'ai pas réussi à faire bosser le solveur dessus, alors j'ai écrit une petite procédure Ajuster qui approche petit à petit les valeurs X optimales de changements de pentes.
Remarque: je ne l'ai fait que pour la courbe bleue. A vous de répéter les formules et l'ajustement pour la courbe orange.
 

Pièces jointes

  • SolEquMCarQuatr_o.xlsm
    327.8 KB · Affichages: 4

job75

XLDnaute Barbatruc
Bonjour Quatr_o, sylvanu, Bernard,

Voyez le fichier joint et ses 2 macros, une pour chaque série.

La variable decal définit l'écart par rapport à l'écart-type, elle est fixée par tâtonnement :
VB:
Sub Etude_Serie1()
Dim x1, x2, x3, x4, debut&, fin&, a, m, b, seb, decal, i&
x1 = -30
x2 = -20
x3 = -10
x4 = 10
With [A1].CurrentRegion
    '---1ère butée---
    debut = Application.Match(x1, .Columns(1))
    fin = Application.Match(x2, .Columns(1))
    Range(.Cells(debut, 1), .Cells(fin, 1)).Name = "X" 'plage nommée
    Range(.Cells(debut, 2), .Cells(fin, 2)).Name = "Y" 'plage nommée
    a = [LINEST(Y,X,1,1)] 'DROITEREG avec statistiques
    m = Application.Index(a, 1, 1)
    b = Application.Index(a, 1, 2)
    seb = Application.Index(a, 2, 2) 'écart-type sur b
    decal = 5 '5 fois l'écart-type
    For i = fin To .Rows.Count
        If .Cells(i, 2) > m * .Cells(i, 1) + b + decal * seb Then
            MsgBox "1ère butée au point " & i & " d'abscisse " & .Cells(i, 1), , "Série1"
            Exit For
        End If
    Next i
    '---2ème butée---
    debut = Application.Match(x3, .Columns(1))
    fin = Application.Match(x4, .Columns(1))
    Range(.Cells(debut, 1), .Cells(fin, 1)).Name = "X" 'plage nommée
    Range(.Cells(debut, 2), .Cells(fin, 2)).Name = "Y" 'plage nommée
    a = [LINEST(Y,X,1,1)] 'DROITEREG avec statistiques
    m = Application.Index(a, 1, 1)
    b = Application.Index(a, 1, 2)
    seb = Application.Index(a, 2, 2) 'écart-type sur b
    decal = 38 '38 fois l'écart-type
    For i = fin To .Rows.Count
        If .Cells(i, 2) > m * .Cells(i, 1) + b + decal * seb Then
            MsgBox "2ème butée au poinr " & i & " d'abscisse " & .Cells(i, 1), , "Série1"
            Exit For
        End If
    Next i
End With
End Sub

Sub Etude_Serie2()
Dim x1, x2, x3, x4, debut&, fin&, a, m, b, seb, decal, i&
x1 = 30
x2 = 20
x3 = 10
x4 = -10
With [D1].CurrentRegion
    '---1ère butée---
    debut = Application.Match(x1, .Columns(1), -1)
    fin = Application.Match(x2, .Columns(1), -1)
    Range(.Cells(debut, 1), .Cells(fin, 1)).Name = "X" 'plage nommée
    Range(.Cells(debut, 2), .Cells(fin, 2)).Name = "Y" 'plage nommée
    a = [LINEST(Y,X,1,1)] 'DROITEREG avec statistiques
    m = Application.Index(a, 1, 1)
    b = Application.Index(a, 1, 2)
    seb = Application.Index(a, 2, 2) 'écart-type sur b
    decal = 0 '0 fois l'écart-type
    For i = fin To .Rows.Count
        If .Cells(i, 2) < m * .Cells(i, 1) + b - decal * seb Then
            MsgBox "1ère butée au point " & i & " d'abscisse " & .Cells(i, 1), , "Série2"
            Exit For
        End If
    Next i
    '---2ème butée---
    debut = Application.Match(x3, .Columns(1), -1)
    fin = Application.Match(x4, .Columns(1), -1)
    Range(.Cells(debut, 1), .Cells(fin, 1)).Name = "X" 'plage nommée
    Range(.Cells(debut, 2), .Cells(fin, 2)).Name = "Y" 'plage nommée
    a = [LINEST(Y,X,1,1)] 'DROITEREG avec statistiques
    m = Application.Index(a, 1, 1)
    b = Application.Index(a, 1, 2)
    seb = Application.Index(a, 2, 2) 'écart-type sur b
    decal = 16 '16 fois l'écart-type
    For i = fin To .Rows.Count
        If .Cells(i, 2) < m * .Cells(i, 1) + b - decal * seb Then
            MsgBox "2ème butée au poinr " & i & " d'abscisse " & .Cells(i, 1), , "Série2"
            Exit For
        End If
    Next i
End With
End Sub
A+
 

Pièces jointes

  • Data v1.xlsm
    265.5 KB · Affichages: 2
Dernière édition:

Quatr_o

XLDnaute Nouveau
Hello ,

Job75 et Dranreb vos deux solution son génial je vous remercie à tout les deux pour vos retour.
PS mon seul hic est que par moment je peux avoir une plage de mesure plus longue quel paramètre dois-je changer pour prendre en compte toutes la plage de mesure ?
 

job75

XLDnaute Barbatruc
Pouvez-vous m'en dire plus svp ? ci-joint la plage avec plus de point
Avec votre nouveau fichier les valeurs x1 x2 x3 x4 n'ont pas a être modifiées.

Par contre les 4 valeurs de decal doivent être adaptées par tâtonnement comme déjà dit.

En retenant les plus petites valeurs possibles.

On trouve ainsi les valeurs 8 72 0 19.
 

Pièces jointes

  • Data v1.1.xlsm
    349.1 KB · Affichages: 1

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
315 127
Messages
2 116 534
Membres
112 771
dernier inscrit
mikadu49