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

昨日は、複数の解を持つゴールシークマクロについて、サブプロシージャをクラスモジュールに移植してみた。
infoment.hatenablog.com
昨日は、複数解の有無を返すフラグを作成するところまでで力尽きた。
そこで今日は、昨日の続きから再開する。
f:id:Infoment:20190403221300p:plain

今回立てた作戦は、以下のとおり。

全ての解を戻り値とするコレクションを作成する。
全ての解は辞書（連想配列）に登録し、重複を排除する。
隣り合う解の真ん中の値を開始値としてゴールシークを行い、既存の値と異なる解が得られた場合コレクションに追加する。
追加が無くなるまで、３．に戻る。

例えば、今回扱っている４次関数は以下の式だ。
f:id:Infoment:20190331103700p:plain

ｙ＝０となるｘを＋側から探した場合と、－側から探した場合を図示すると、以下のようなイメージになる。
f:id:Infoment:20190403222144p:plain

ここまでが、昨日の「SingleSolutionFlag」を求めた時点までの話。
そこでここから発展させ、真ん中の値である「2.5」から、もう一度探させるわけだ。
f:id:Infoment:20190403222520p: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

Private InitialValue As Double
Private Dict As Dictionary

Private Sub Class_Initialize()
    InitialValue = 10 ^ 30
    Set Dict = New Dictionary
End Sub

Public Function GoalSeekCollection() As Collection
    Dim Col As Collection
    Set Col = New Collection
        If SingleSolutionFlag = False Then
            Col.Add Dict.Keys(0)
            Col.Add Dict.Keys(1)
        Else
            Col.Add Dict.Keys(0)
            Exit Function
        End If
    
    Dim i As Long
    Dim temp As Double
    Dim Flag As Boolean
    
        Do
            Flag = False
            For i = 1 To Col.Count - 1
                InitialValue = (Col.Item(i) + Col.Item(i + 1)) / 2
                temp = GetSingleGoal
                If Dict.Exists(temp) = False Then
                    Col.Add temp
                    Dict(temp) = goal_value
                    Flag = True
                End If
            Next
            If Flag = False Then Exit Do
        Loop
        
        Set GoalSeekCollection = Col

End Function

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

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

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

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

    ' 初期値。
        changing_cell = InitialValue * seek_direction

    ' 一致率。
    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
        
        GSC.GoalSeekCollection

End Sub