ゴールシークとマクロ ③ コレクションのソート - Infomentのブログ～Excel VBA奮闘記～

昨日は、複数の解を持つゴールシークマクロについて、成功か！？と一瞬思うところまでたどり着くことが出来た。
infoment.hatenablog.com
しかし、実際は不充分。解が５つ以上の場合も、４つまでしか答えが出ない。
なんでだろう。
そこで今日は、その解決に挑戦する。
f:id:Infoment:20190404220218p:plain
上手くいかなかった原因は、改めて考えてみたら、すぐに分かった。得られた解について、小さい方から順番に検証していくためには、解を貯め込んだコレクションの中身を小さい順に並び替えておく必要があったわけで。

ということで、コレクションのソートを追加することで、この問題は解決する気がする。調べてみると、コレクションをソートしてくれる便利な関数は無いようなので、以下の手順で並び替えを行うことにした。

コレクションを、一旦配列に変換
配列を昇順にソート
ソート後の配列をコレクションに変換

配列のソートについては、昔作成したものを再利用する。
infoment.hatenablog.com

クラスモジュール（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 Enum SortDirection
    SortAscending
    SortDescending
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
            Set col = SortCollection(col)
        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

' コレクションを配列に変換。
Private Function ToArray(col As Collection) As Variant
    Dim seq As Variant
    ReDim seq(1 To col.Count)
    Dim i As Long
        For i = 1 To UBound(seq)
            seq(i) = col.Item(i)
        Next
        
        ToArray = seq
End Function

' 配列をコレクションに変換。
Private Function ToCollection(seq As Variant) As Collection
    Dim col As Collection
    Set col = New Collection
    Dim i As Long
        For i = 0 To UBound(seq)
            col.Add seq(i)
        Next
        
        Set ToCollection = col
End Function

' 配列をソート
Private Function SortSeq(seq As Variant, _
               Optional sort_type As SortDirection = SortAscending) As Variant
    Dim aryList As Object
    Dim s As Variant
    Set aryList = CreateObject("System.Collections.ArrayList")
    
    For Each s In seq
        Call aryList.Add(s)
    Next
    
    Select Case sort_type
        Case SortAscending
            ' 昇順でソート。
            Call aryList.Sort
        Case SortDescending
            ' 昇順でソートののち、降順へ反転。
            Call aryList.Sort
            Call aryList.Reverse
    End Select
    
    SortSeq = aryList.ToArray
End Function

' コレクションをソート
Private Function SortCollection(col As Collection) As Collection
    Dim seq As Variant
        ' コレクションを配列に変換。
        seq = ToArray(col)
        ' 配列を昇順でソート。
        seq = SortSeq(seq)
        ' 配列をコレクションに変換。
    Set SortCollection = ToCollection(seq)
End Function

それでは、６次関数でゴールシークしてみる。
f:id:Infoment:20190404221121p:plain

標準モジュール

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