ゴールシークとマクロ ② クラスモジュール化(2)
昨日は、複数の解を持つゴールシークマクロについて、サブプロシージャをクラスモジュールに移植してみた。
infoment.hatenablog.com
昨日は、複数解の有無を返すフラグを作成するところまでで力尽きた。
そこで今日は、昨日の続きから再開する。
今回立てた作戦は、以下のとおり。
- 全ての解を戻り値とするコレクションを作成する。
- 全ての解は辞書(連想配列)に登録し、重複を排除する。
- 隣り合う解の真ん中の値を開始値としてゴールシークを行い、既存の値と異なる解が得られた場合コレクションに追加する。
- 追加が無くなるまで、3.に戻る。
例えば、今回扱っている4次関数は以下の式だ。
y=0となるxを+側から探した場合と、-側から探した場合を図示すると、以下のようなイメージになる。
ここまでが、昨日の「SingleSolutionFlag」を求めた時点までの話。
そこでここから発展させ、真ん中の値である「2.5」から、もう一度探させるわけだ。
結果、「3」がみつかる。今度は、
- 2=(1+3)÷2
- 3.5=(3+4)÷2
の2点から探しに行く。これを、新たな解が見つからなくなるまで繰り返す。
以上を踏まえ、昨日の内容を修正した結果が↓こちら。
クラスモジュール(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の場合、0.01未満になったらループを抜ける。 Case 0 If Abs(changing_cell.Value) < 0.01 Then Exit For ' 一致率が1未満になったら、ループを抜ける。 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
↓ 結果が、こちら。
GoalSeekCollection の中には、解となる1,2,3,4が全て入っている。これは、上手くいったかもしれない。
よし、ここは調子に乗って、さらに6次方程式で試してみよう。
↓ あれ?答えが4つしかない。
・・・明日に続きます。
参考まで。