В Excel есть инструмент Подбор Параметра — работает он быстро, но не всегда точно Возникла необходимость прокачать его или создать свой инструмент Решения на VBA мне максимально интересны, но предлагаю использовать любые инструменты для достижения результата — кто на чём может, как говориться
Option Explicit
Option Private Module
'====================================================================================================
Dim clTarget As Range, clNeed As Range, clChange As Range
'----------------------------------------------------------------------------------------------------
Sub Variables()
Set clTarget = Range("A2"): Set clNeed = Range("C2"): Set clChange = Range("E2")
End Sub
'----------------------------------------------------------------------------------------------------
Sub iMsg(iAccuracy#, iTime!)
Const frmt$ = "#,##0.000000000000000"
MsgBox _
"Accuracy:" & vbTab & vbTab & Format$(iAccuracy, frmt) & vbLf & _
"Achieved?" & vbTab & vbTab & (Abs(clTarget - clNeed) <= iAccuracy) & vbLf & vbLf & _
"Result:" & vbTab & vbTab & Format$(clTarget, frmt) & vbLf & _
"Need:" & vbTab & vbTab & Format$(clNeed, frmt) & vbLf & _
"Difference:" & vbTab & Format$(Abs(clTarget - clNeed), frmt) & vbLf & _
"Parameter:" & vbTab & Format$(clChange, frmt) _
, vbInformation, Format$(iTime, "0.00 sec")
End Sub
'====================================================================================================
'====================================================================================================
'====================================================================================================
Sub GS_Solver()
Variables
SolverReset
SolverOptions MaxTime:=10, Iterations:=0, Precision:=0.0000000001, Convergence:=0.0000000001, StepThru:=False, Scaling:=False, AssumeNonNeg:=False, Derivatives:=1
SolverOptions PopulationSize:=0, RandomSeed:=0, MutationRate:=0.075, Multistart:=False, RequireBounds:=False, MaxSubproblems:=0, MaxIntegerSols:=0, IntTolerance:=0.1, SolveWithout:=False, MaxTimeNoImp:=30
SolverOk SetCell:=clTarget.Address(0, 0, xlA1), MaxMinVal:=3, ValueOf:=clNeed.Value2, ByChange:=clChange.Address(0, 0, xlA1), Engine:=1, EngineDesc:="GRG Nonlinear"
SolverSolve True
Application.StatusBar = False
End Sub
'====================================================================================================
Sub GS_Tool()
Variables
clTarget.GoalSeek Goal:=clNeed, ChangingCell:=clChange
End Sub
'====================================================================================================
Sub GS_My()
Variables
MsgBox "There is NO CURRENT code", vbExclamation, "NOTHING": Exit Sub
' FindValue clChange, clTarget, clNeed, 0, True
End Sub
'====================================================================================================
'====================================================================================================
'====================================================================================================
'Function FindValue(clTrg As Range, clCh As Range, Optional ByVal iTrg#, Optional ByVal iAccuracy#, Optional ByVal Msg As Boolean) As Boolean
'Dim v#, v1, d#, d1#, iStep#, t!, c&, iSgn&, AC&
'Const frmt$ = "#,##0.000000000000000", cyc& = 100000
'
't = Timer: Application.ScreenUpdating = False: Variables
'AC = Application.Calculation: Application.Calculation = xlCalculationAutomatic
'
'v = 0: clCh.Value2 = v: d = Abs(clTrg.Value2 - iTrg)
'clCh.Value2 = 0.000000000000001: d1 = Abs(clTrg.Value2 - iTrg)
'If d1 > d Then iSgn = -1 Else iSgn = 1
'iStep = 1
'
'Do
'
' c = c + 1
'Loop Until c = cyc
'
'
'ex: FindValue = (d1 <= iAccuracy)
'
'Application.Calculation = AC
'Application.ScreenUpdating = True
'If Not Msg Then Exit Function
'
't = Timer - t: iMsg iAccuracy, t
'MsgBox "Cycles: " & Format$(n, "#,##0") & " out of " & Format$(cyc, "#,##0"), vbInformation, Format$(t, "0.00 sec")
'End Function
'====================================================================================================
На данный момент реализован подбор параметра одноимённым инструментом и через Поиск Решения (должна быть подключена надстройка) — спасибо sokol92. Последний работает быстрее, точнее, а также МОЖЕТ (инструмент - не всегда или не самое близкое) найти ближайшее решение, если заданное далеко от любого возможного (на скрине) Поэтому для такого рода задач необходимо другое решение
Тэги для поиска: комбинаторика, подбор параметра, поиск решения, тесты
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Обновил описание, файл и скрин Убрал свой недокод, чтобы не позориться и сделал вариант с Поиском Решения
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
MCH, маэстро пришёл Огромное спасибо - беру на вооружение!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄