ゴールシークとマクロ ① 無限遠からのアプローチ（４）

昨日は、恐らく既定の回数内に辿り着けなかったであろう「ゴールシーク」の処理について、目標値到達まで処理を繰り返させることに挑戦した。
infoment.hatenablog.com
ゴールにたどり着いたか否かについては、目標値との一致率１％未満で評価してみた。しかし目標値が０の場合、０で割り算することになって都合が悪い。そこで今日は、その解決に挑戦する。
f:id:Infoment:20190401225419p:plain
正直、どのような方法が正解か分からない。そこで今回は目標値が０の場合、
「一致率１％未満」
に合わせて、算出した値が「０．０１未満」であることを条件にしてみよう。都合が悪くなれば、改めて調整することにする。

更についでに、以下を引数にしてみた。
・変化させるセル
・目標値を求めるセル
・目標値
・＋側から算出するか、－側から算出するか

Enum SeekDirection
    SeekAscending = 1
    SeekDescending = -1
End Enum

Sub GoalSeekTest(goal_cell As Range, _
                 changing_cell As Range, _
                 goal_value As Double, _
        Optional seek_direction As SeekDirection = SeekAscending)

    ' 初期値。
    Dim InitialValue As Double
        InitialValue = 10 ^ 30 * seek_direction
        changing_cell = InitialValue

    ' 一致率。
    Dim MatchRatio(1 To 10) As Variant
    Dim i As Long
        For i = 1 To 10
            goal_cell.GoalSeek Goal:=goal_value, ChangingCell:=changing_cell
            Select Case goal_value
                ' 目標値が０の場合、0.01未満になったらループを抜ける。
                Case 0
                    If Abs(changing_cell.Value) < 0.01 Then Exit For
                ' 一致率が１未満になったら、ループを抜ける。
                Case Else
                    MatchRatio(i) = Abs((goal_value - goal_cell) / goal_value * 100)
                    If i >= 2 Then
                        If Abs(MatchRatio(i) - MatchRatio(i - 1)) < 1 Then Exit For
                    End If
            End Select
        Next
End Sub

昨日と同じ４次関数について、↓ こちらでテストしてみた。

Sub hoge()
    GoalSeekTest goal_cell:=Range("H3"), _
                 changing_cell:=Range("G3"), _
                 goal_value:=0, _
                 seek_direction:=SeekAscending
End Sub