Option Explicit Option Base 1 Option Private Module Public fini As Boolean Public ligListeAbs As Long Public tabl As Variant Public shDest As Worksheet, shDatas As Worksheet, shCourbe As Worksheet Public datasX As Range, datasY As Range Public modeValLibre As Boolean Public memoOK As Boolean Public Const offsetLigData As Long = 3 Sub multiAbscisses() Dim ctrl As Control ReDim tabl(10) Set shDest = Worksheets("Liste Abscisses") Set shDatas = Worksheets("DONNÉES") Set shCourbe = Worksheets("EXEMPLE") Set datasX = shDatas.[B1].Offset(offsetLigData, 0).Resize(shDatas.[B65536].End(xlUp).Row - offsetLigData, 1) Set datasY = shDatas.[C1].Offset(offsetLigData, 0).Resize(shDatas.[B65536].End(xlUp).Row - offsetLigData, 1) ligListeAbs = Application.Max(ligListeAbs, 2) ' déselection OptionButton For Each ctrl In UserForm1.Controls 'Vérifie si OptionButton If TypeOf ctrl Is MSForms.OptionButton Then 'si OptionButton sélectionné ctrl.Value = False End If Next UserForm1.SpinBtnLigAbs.Min = 2 UserForm1.SpinBtnLigAbs.Max = shDest.[A65536].End(xlUp).Row UserForm1.SpinBtnLigAbs.Value = Application.Max(UserForm1.SpinBtnLigAbs.Value, 2) initAffOptionBtn UserForm1.Show False End Sub Sub initAffOptionBtn() Dim ctrl As Control, i As Long, msg As String ligListeAbs = UserForm1.SpinBtnLigAbs.Value msg = " Abscisse en cours : " & Format(shDest.Cells(ligListeAbs, 1), "0.000") & " (ligne " & ligListeAbs & ")" UserForm1.Label1.Caption = msg tabl = interpolation(datasX, datasY, shDest.Cells(ligListeAbs, 1)) ' pour initialisation 1er affichage userform For i = 1 To 10 For Each ctrl In UserForm1.Controls If ctrl.Name = "OptionButton" & i Then If tabl(i) > 0 Then ctrl.Caption = FormatEng(tabl(i)) ctrl.Visible = True If CDbl(ctrl.Caption) = shDest.Cells(ligListeAbs, 2) Then ctrl.Value = True Else ctrl.Value = False End If ctrl.Enabled = True Else ctrl.Caption = "" ctrl.Visible = False ctrl.Value = False End If Exit For End If Next ctrl Next i ' maj ligne verticale dans la courbe shCourbe.[E31] = shDest.Cells(ligListeAbs, 1) End Sub Sub affModeValLibre() Dim ctrl As Control, i As Long, nbval As Long ' tabl = interpolation(datasX, datasY, UserForm1.TbxValeurLibre) For i = 1 To 10 For Each ctrl In UserForm1.Controls If ctrl.Name = "OptionButton" & i Then If tabl(i) > 0 Then ctrl.Caption = FormatEng(tabl(i)) ctrl.Visible = True ctrl.Value = False ctrl.Enabled = False Else ctrl.Caption = "" ctrl.Visible = False ctrl.Value = False End If Exit For End If Next ctrl Next i ' maj ligne verticale dans la courbe shCourbe.[E31] = CDbl(UserForm1.TbxValeurLibre) End Sub Function interpolation(datasX As Range, datasY As Range, valeur As Double, Optional enColonne As Boolean = False) As Variant Dim lig As Long, pente As Double, ordonnéeOri As Double, ordonnéePt As Double, tablOrd As Variant, ptr As Long ' tableau de stockage des ordonnées des intersections ReDim tablOrd(10) ' pointeur d'intersections ptr = 1 ' pour chaque ligne de données For lig = 1 To datasX.Rows.Count - 1 ' si l'abcisse et la suivante encadre la valeur recherchée If (datasX(lig, 1) >= valeur And datasX(lig + 1, 1) <= valeur) Or (datasX(lig, 1) <= valeur And datasX(lig + 1, 1) >= valeur) Then ' calcul de la droite de régression linéaire pente = Application.WorksheetFunction.Slope(datasY(lig, 1).Resize(2, 1).Value, datasX(lig, 1).Resize(2, 1).Value) ordonnéeOri = WorksheetFunction.Intercept(datasY(lig, 1).Resize(2, 1).Value, datasX(lig, 1).Resize(2, 1).Value) ' évaluation de l'ordonnée ordonnéePt = pente * valeur + ordonnéeOri ' si l'ordonnée calculée est dans les critères If ordonnéePt <= 0.0000005 And ordonnéePt >= 0 Then ' stocker l'ordonnée tablOrd(ptr) = ordonnéePt ' ordonnée suivante ptr = ptr + 1 ' si maxi intersection atteint, on sort If ptr > UBound(tablOrd) Then Exit For End If End If Next lig ' retourner la matrice de résultats If enColonne Then interpolation = Application.Transpose(tablOrd) Else interpolation = tablOrd End If End Function Function FormatEng(Nombre As Variant, Optional nbDecimales As Long = 2) As String 'source : http://www.generation-nt.com/reponses/nombre-format-ingenieur-entraide-3222151.html#17586851 Dim Exposant As Long Dim Parts() As String Parts = Split(Format(Nombre, "0.0#############E+0"), "E") Exposant = 3 * Int(Parts(1) / 3) FormatEng = Format(Parts(0) * 10 ^ (Parts(1) - Exposant), "0." & String(nbDecimales, "0")) & "E" & Format(Exposant, "+0;-0") End Function
Option Explicit Private Sub Label2_Click() End Sub Private Sub TbxValeurLibre_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If KeyAscii <> 44 And KeyAscii <> 48 And KeyAscii <> 49 And KeyAscii <> 50 And KeyAscii <> 51 And KeyAscii <> 52 And KeyAscii <> 53 And KeyAscii <> 54 And KeyAscii <> 55 And KeyAscii <> 56 And KeyAscii <> 57 Then 'Filtre les valeurs KeyAscii = 127 End If End Sub Private Sub BtnDernierVal_Click() If modeValLibre Then TbxValeurLibre = "" If BtnDernierVal.Tag <> "" Then UserForm1.SpinBtnLigAbs.Value = BtnDernierVal.Tag End Sub Private Sub BtnQuitter_Click() If modeValLibre Then TbxValeurLibre = "" fini = True Me.Hide ' suppression ligne en cours dans shDest en vert shDest.[A2].Resize(shDest.[A65536].End(xlUp).Row - 1, 2).Interior.ColorIndex = xlNone End Sub Private Sub BtnValider_Click() Dim ctrl As Control, ok As Boolean, i As Long ligListeAbs = Me.SpinBtnLigAbs.Value ' ' recherche optionbutton validé For Each ctrl In UserForm1.Controls 'Vérifie si OptionButton If TypeOf ctrl Is MSForms.OptionButton Then 'si OptionButton sélectionné If ctrl.Value Then ok = True Exit For End If End If Next If ok Then shDest.Cells(ligListeAbs, 2) = CDbl(ctrl.Caption) UserForm1.BtnDernierVal.Tag = ligListeAbs Else MsgBox ("Pas de valeur sélectionnée") End If End Sub Private Sub TbxValeurLibre_Change() Dim c As Range If IsNumeric(TbxValeurLibre) Then modeValLibre = True UserForm1.BtnValider.Enabled = False 'TbxValeurLibre = Application.Max(Application.Min(TbxValeurLibre, 1), 0) If Not memoOK Then TbxValeurLibre.Tag = shCourbe.[E31] memoOK = True End If affModeValLibre Else 'ElseIf TbxValeurLibre <> "." Then modeValLibre = False shCourbe.[E31] = TbxValeurLibre.Tag memoOK = False initAffOptionBtn End If End Sub Private Sub SpinBtnLigAbs_Change() If modeValLibre Then TbxValeurLibre = "" initAffOptionBtn End Sub Private Sub SpinButton1_Change() ' scrolling Hz Select Case SpinButton1 Case 0 ActiveWindow.SmallScroll Toleft:=1 Case 2 ActiveWindow.SmallScroll Toright:=1 End Select SpinButton1.Value = 1 End Sub Private Sub ScrollBar1_Change() ' scrolling Vt Select Case ScrollBar1 Case 0 ActiveWindow.SmallScroll up:=3 Case 2 ActiveWindow.SmallScroll down:=3 End Select ScrollBar1.Value = 1 End Sub Private Sub TbxLigne_Exit(ByVal Cancel As MSForms.ReturnBoolean) If modeValLibre Then TbxValeurLibre = "" If IsNumeric(TbxLigne) Then TbxLigne = Application.Max(Application.Min(CLng(TbxLigne), SpinBtnLigAbs.Max), SpinBtnLigAbs.Min) UserForm1.SpinBtnLigAbs.Value = TbxLigne End If End Sub Private Sub OptionButton1_Click() Me.BtnValider.Enabled = True End Sub Private Sub OptionButton2_Click() Me.BtnValider.Enabled = True End Sub Private Sub OptionButton3_Click() Me.BtnValider.Enabled = True End Sub Private Sub OptionButton4_Click() Me.BtnValider.Enabled = True End Sub Private Sub OptionButton5_Click() Me.BtnValider.Enabled = True End Sub Private Sub OptionButton6_Click() Me.BtnValider.Enabled = True End Sub Private Sub OptionButton7_Click() Me.BtnValider.Enabled = True End Sub Private Sub OptionButton8_Click() Me.BtnValider.Enabled = True End Sub Private Sub OptionButton9_Click() Me.BtnValider.Enabled = True End Sub Private Sub OptionButton10_Click() Me.BtnValider.Enabled = True End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionJe me demande en réalité comment utiliser la collection TrendLines avec un graphique, lorsqu'existe plus d'une intersection.
Dis-moi : ta courbe a-t-elle toujours à peu près le même aspect (faussement sinusoïdal )?
Si oui : peux-tu envisager l'inversion des abscisses et des ordonnées (donner sur l'axe des ordonnées des valeurs de la colonne abscisses et sur l'axe des abscisses celles de la colonne ordonnées ? (car là est peut-être la solution, avec l'ajout une trendline (courbe de tendance) de type "movingaverage" (constante VBA/Excel xlMovingAvg).