ゴールシークとマクロ ② クラスモジュール化（１）

昨日は、ゴールシークの結果が本当にゴールなのか（＝途中で力尽きて倒れていないか）を確認してみた。
infoment.hatenablog.com
今日は、今までの結果をクラスモジュールに移植してみる。
f:id:Infoment:20190402224259p:plain
ゴールシークにおいて、計算式が入っているセルと値を変化させるセルは、今回のケースで何度も登場する。そこで今回も安易にクラスモジュールに移植してみた。

作戦としては、こうだ。

目標値に、＋側から近づけてみる。
目標値に、－側から近づけてみる。
二つの結果が一致するならば、目標を導く値は一つ（＝処理終了）

クラスモジュール（GoalSeekClass）

Option Explicit

Public goal_cell As Range
Public changing_cell As Range
Public goal_value As Double

Public Enum SeekDirection
    SeekAscending = 1
    SeekDescending = -1
End Enum

Public Function SingleSolutionFlag() As Boolean
    If SeekMax = SeekMin Then
        SingleSolutionFlag = True
    Else
        SingleSolutionFlag = False
    End If
End Function

Private Function SeekMax()
    SeekMax = GetSingleGoal(SeekAscending)
End Function

Private Function SeekMin()
    SeekMin = GetSingleGoal(SeekDescending)
End Function

Private Function GetSingleGoal(Optional seek_direction As SeekDirection = SeekAscending) As Double

    ' 初期値。
    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

        GetSingleGoal = WorksheetFunction.Round(changing_cell.Value, 3)

End Function

標準モジュール

Sub hoge()

    Dim GSC As GoalSeekClass
    Set GSC = New GoalSeekClass

    Set GSC.goal_cell = Range("H3")
    Set GSC.changing_cell = Range("G3")
        GSC.goal_value = 0

    MsgBox GSC.SingleSolutionFlag

End Sub