Sub Macro_tension_globale()
Dim RgCbl As Range, VCible As Double, RgVar As Range
RgCbl = Range("E30")
VCible = Range("N4")
RgVar = Range("O4")
XSvg = RgVar.Value: If RgVar.HasFormula Then RgVar.Value = XSvg
If Not RgCbl.GoalSeek(Goal:=VCible, ChangingCell:=RgVar) Then
Rép = MsgBox("GoalSeek impuissant." & vbLf & "Voulez vous restaurer " & DescrZones(RgVar) & " à " & XSvg & " ?", _
vbYesNoCancel + vbQuestion, "Valeur cible")
If Rép = vbYes Then RgVar.Value = XSvg: UfSelect.ÉtapePlage 2, AutreMsg:="La cellule " & DescrZones(RgCbl) _
& " n'a pu atteindre " & VCible & vbLf & "par aucune modification de cette cellule."
If Rép <> vbNo Then Exit Sub
End If
ApprocherMieux RgCbl, VCible, RgVar, 0.001
ApprocherMieux RgCbl, VCible, RgVar, -0.00001
ApprocherMieux RgCbl, VCible, RgVar, 0.0000001
ApprocherMieux RgCbl, VCible, RgVar, -0.000000001
End Sub
-----------------------------------------------------------
Sub ApprocherMieux(RgCible As Range, VCible As Double, RgModif As Range, Ajout As Double)
Dim X1 As Double, Y1 As Double, X2 As Double, Y2 As Double
RgCible = Range("E30")
VCible = Range("N4")
RgModif = Range("O4")
X1 = RgModif.Value: On Error GoTo Resto: Y1 = RgCible.Value
X2 = X1 + Ajout: RgModif.Value = X2: Y2 = RgCible.Value
If Y2 <> Y1 Then
RgModif.Value = X1 + (X2 - X1) * (VCible - Y1) / (Y2 - Y1)
If Abs(RgCible.Value - VCible) < Abs(Y1 - VCible) Then Exit Sub
End If
Resto: RgModif.Value = X1
End Sub