数独（再挑戦）⑦ 禁断の総当たり - Infomentのブログ～Excel VBA奮闘記～

前回は、行・列および３×３の範囲に候補となる数が一つしかないなら、その数で確定させてみた。
infoment.hatenablog.com

今日はいよいよ、禁断の「総当たり」に挑戦する。
f:id:Infoment:20191208161812p:plain

出来れば、最後の最後まで論理的に解きたかった。しかしこれ以上は、マクロが複雑になりすぎて、自分でも検証できなくなる。

そこで、こう考えた。ピタゴラスイッチの最初の一押しのように、或いは北斗神拳の経絡秘孔のように、必殺の急所がどこかに一つ有るはずだ。そのセルの数さえ確定させれば、あとはパタパタとゴールまでたどり着く、必殺の一マスが。
※ちなみに前回（半年前）は、総当たりのイメージを具現化できずに挫折していた。

というわけで残ったセルで取りうる値を、一つずつ順番に試してみることにした。

空白セルに、取りうる値を一つ入れる。
検証。
解き切れなかったら、１．に戻る。

そこでまず、指定時点での状態が最終解かどうかを返す関数を作成。

' 最終解の正誤判定。
' 正・・・True
' 誤・・・False
Private Function CheckAnswer() As Boolean
    Dim i As Long
        For i = 1 To 9
            ' 全セル中、１～９までの数が９個以外の場合、間違い。
            If ArrayCountIF(AnswerArray, i) <> 9 Then
                CheckAnswer = False
                Exit Function
            End If
        Next
        CheckAnswer = True
End Function

次いで、未確定セルの情報で、多段階配列を作成する。

' （あくまでこのマクロ内における）論理的解法で解き切れなかった残り。
Private Function UnfixedArray() As Variant
    Dim arr() As Variant
    ReDim arr(1 To 27 * 27)
    Dim i As Long: i = 1
    Dim r As Long
    Dim c As Long
    
        ' ２７×２７の中に残っている０以外の数値のうち、セルの値を
        ' 確定しきれなかったもので多段階配列を作成する。
        For r = 1 To 27
            For c = 1 To 27
                Dim r2 As Long: r2 = WorksheetFunction.RoundUp(r / 3, 0)
                Dim c2 As Long: c2 = WorksheetFunction.RoundUp(c / 3, 0)
                If TempArray(r, c) <> 0 Then
                    If FixedNumber(r2, c2) = 0 Then
                        arr(i) = Array(r2, c2, CLng(TempArray(r, c)))
                        i = i + 1
                    End If
                End If
            Next
        Next
    ReDim Preserve arr(1 To i - 1)
    UnfixedArray = arr
End Function

これを元に、既存のSetAnswerを改修した。

Public Sub SetAnswer()
    Dim r As Long
    Dim c As Long
    Dim n As Long
    Dim SumAll As Long
    Dim Counter As Long: Counter = 1
    
        ' 編集の有無を確認するために、予め配列の合計値を求めておく。
        ' ※何らかの編集があれば、１以上の値が０に置き換わり、合計も変わる。
        SumAll = WorksheetFunction.Sum(TempArray)
        
        ' 編集の前後で合計値の差が無くなるまで、つまり何も置き換わらなくなる
        ' まで繰り返す。
        Do
            For r = 1 To 9
                For c = 1 To 9
                    n = FixedNumber(r, c)
                    If n <> 0 Then
                        DeleteNumber r, c, n
                    End If
                Next
            Next
            
            UniqueExistence
            
            ' 一巡したところで解答取得。
            GetAnswerArray
            
            ' 解答貼り付け範囲に、解答を格納した配列を貼り付け。
            DestinationRange = AnswerArray
            
            ' 0.2秒待つ。
            Application.Wait [Now() + "00:00:00.2"]
            
            Dim arr As Variant
            Dim iMax As Long
            Dim SaveArray As Variant
            
            ' ------------------↓↓今回追加したところ↓↓------------------
            
            If SumAll <> WorksheetFunction.Sum(TempArray) Then
                SumAll = WorksheetFunction.Sum(TempArray)
            Else
                If CheckAnswer Then Exit Do
            
                If Counter = 1 Then
                    ' 未確定情報を配列に格納。
                    arr = UnfixedArray
                    ' 総当たりの最大回数。
                    iMax = UBound(arr)
                    ' 総当たり突入前の解答を退避させる。
                    SaveArray = TempArray
                Else
                    ' 解答を総当たり前の状態に戻す。
                    TempArray = SaveArray
                End If
                
                Dim r_index As Long
                    r_index = arr(Counter)(0)
                Dim c_index As Long
                    c_index = arr(Counter)(1)
                Dim fixed_number As Long
                    fixed_number = arr(Counter)(2)
                
                FixedCell r_index, c_index, fixed_number
                
                Application.StatusBar = "総当たりモード中：" & Counter & " / " & iMax & "巡目"
                
                Counter = Counter + 1
            End If
            
            ' ------------------↑↑今回追加したところ↑↑------------------
            
            ' 念のため、仮の措置として、２７×２７回繰り返したらループを抜ける。
            If Counter >= 27 * 27 Then Exit Do
        Loop
End Sub

テスト用のマクロを再掲。

Sub test()
    Dim Sudoku As New Sudoku
    ' 出題範囲をセット。
    Set Sudoku.SourceRange = Sheet1.Range("A1:I9")
    ' 解答貼り付け先をセット。
    Set Sudoku.DestinationRange = Sheet1.Range("K1:S9")
        
        ' 初期化。
        Sudoku.InitArray
        
        ' 解答貼り付け。
        Sudoku.SetAnswer
        
End Sub