数独（再挑戦）⑧ 必殺の一マスを見える化。そして総まとめ。

昨日は数独の解法において行き詰まり、禁断の「総当たり」に手を出した。
infoment.hatenablog.com
私の脳では、これが精いっぱい。

あれこれ試したところ、現時点でのマクロでも正解に辿り着けない問題があった。完璧には、まだまだ届かぬようで。

そこで今回は、昨日のテーマでもあった「急所の一マス」がどこにあるか、見える化してみた。今日は本シリーズ最終回のため、全文を折りたたんで載せておく。

◆「Sudoku」ソースコード（クリックで展開）◆

 Option Explicit

' 出題された９×９の範囲。
Public SourceRange As Range

' 解答を張り付ける範囲。
Public DestinationRange As Range

' 解答の過程で使用する２７×２７の配列。
Public TempArray As Variant

' 解答となる９×９を格納する配列。
Private AnswerArray As Variant

' 原点
Dim r0 As Long
Dim c0 As Long

Enum OriginIndex
    OriginR
    OriginC
End Enum

' 出題された９×９を格納する配列。
Private Property Get SourceArray() As Variant
    SourceArray = SourceRange.Value
End Property

Private Sub Class_Initialize()
    ' TempArray初期化。
    TempArray = BaseArray
End Sub

' 真っ新の２７×２７配列。
Private Property Get BaseArray() As Variant
    Dim r As Long
    Dim c As Long
    Dim arr(1 To 27, 1 To 27) As Variant
        For r = 1 To 27
            For c = 1 To 27
                arr(r, c) = ((r - 1) Mod 3) * 3 + (c - 1) Mod 3 + 1
            Next
        Next
        BaseArray = arr
End Property

Public Sub InitArray()
    Dim r As Long
    Dim c As Long
    For r = 1 To 9
        For c = 1 To 9
            If IsEmpty(SourceArray(r, c)) = False Then
                FixedCell r, c, CLng(SourceArray(r, c))
            End If
        Next
    Next
    
    With SourceRange
        ' 出題範囲の文字色を、いったん全て黒にする。
        .Font.Color = vbBlack
        ' 空欄のみ、濃赤に変更する。
        .SpecialCells(xlCellTypeBlanks).Font.Color = 192
        ' 文字色の変更結果を貼り付け先に反映するために、同範囲をコピーする。
        .Copy
    End With
    ' 解答貼り付け範囲に貼り付け。
    DestinationRange.PasteSpecial xlPasteAll
    Application.CutCopyMode = False
    SourceRange.Cells(1, 1).Select
End Sub
                            
' ９×９の範囲に於いて指定したセルを構成する３×３の配列について、
' 指定値以外を０にして確定させる。
Private Sub FixedCell(r_index As Long, c_index As Long, fixed_number As Long)

    ' 原点を取得。
    r0 = OriginPoint(r_index, c_index)(OriginIndex.OriginR)
    c0 = OriginPoint(r_index, c_index)(OriginIndex.OriginC)

    Dim r As Long
    Dim c As Long
        For r = 1 To 3
            For c = 1 To 3
                If 3 * (r - 1) + c <> fixed_number Then
                    TempArray(r0 + r, c0 + c) = 0
                End If
            Next
        Next
End Sub

Private Function OriginPoint(r_index As Long, c_index As Long) As Variant
    ' ９×９で指定した１つのセルを構成する３×３の配列を抽出。
    ' 例えば２行３列目が属する３×３配列の起点の一つ前は、
    ' （２－１）×３＝３
    ' （３－１）×３＝６
    ' つまり（３，６）が原点（０，０）なる。
    Dim arr(1) As Variant
        arr(OriginIndex.OriginR) = (r_index - 1) * 3
        arr(OriginIndex.OriginC) = (c_index - 1) * 3
        
        OriginPoint = arr
End Function

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
            
            ' １秒待つ。
            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)
                    
                With DestinationRange
                    .Interior.Color = xlNone
                    .Cells(r_index, c_index).Interior.Color = vbYellow
                End With
                
                    FixedCell r_index, c_index, fixed_number
                
                    Application.StatusBar = "総当たりモード中：" & Counter & " / " & iMax & "巡目"
                
                    Counter = Counter + 1
                    If Counter = UBound(arr) Then Exit Do
            End If
        Loop
End Sub

' ９×９の任意セルの数値が確定している場合、その数値を返す。
' 確定していない場合は０を返す。
Private Function FixedNumber(r_index As Long, c_index As Long) As Long
    Dim arr As Variant
        arr = DetailArray(r_index, c_index)
        ' ０の数を数えることで、確定しているか否かを判別する。
        If ArrayCountIF(arr, 0) = 8 Then
            ' 確定値以外は０なので、３×３の範囲の和で求まる。
            FixedNumber = WorksheetFunction.Sum(arr)
        Else
            FixedNumber = 0
        End If
End Function

' ９×９の任意のセルを、２７×２７の配列から抜き出す関数。
Private Function DetailArray(r_index As Long, c_index As Long) As Variant
    ' 原点を取得。
    r0 = OriginPoint(r_index, c_index)(OriginIndex.OriginR)
    c0 = OriginPoint(r_index, c_index)(OriginIndex.OriginC)
        
    Dim arr(1 To 3, 1 To 3) As Variant
    Dim r As Long
    Dim c As Long
        For r = 1 To 3
            For c = 1 To 3
                arr(r, c) = TempArray(r0 + r, c0 + c)
            Next
        Next
        
        DetailArray = arr
End Function

' CountIFの配列版。
' 指定配列内の指定値を数えて返している。
Private Function ArrayCountIF(source_array As Variant, _
                              search_criteria As Variant) As Long
    Dim Counter As Long
    Dim a As Variant
        On Error Resume Next
        For Each a In source_array
            If a = search_criteria Then
                Counter = Counter + 1
            End If
        Next
        On Error GoTo 0
        
        ArrayCountIF = Counter
End Function

Private Sub DeleteNumber(r_index As Long, _
                         c_index As Long, _
                         delete_number As Long)
    Dim r As Long
    Dim c As Long
    
    ' 行方向。
        r0 = OriginPoint(r_index, c_index)(OriginIndex.OriginR)
        For r = 1 To 3
            For c = 1 To 27
                If TempArray(r0 + r, c) = delete_number Then
                    If WorksheetFunction.RoundUp(c / 3, 0) <> c_index Then
                        TempArray(r0 + r, c) = 0
                    End If
                End If
            Next
        Next
    
    ' 列方向。
        c0 = OriginPoint(r_index, c_index)(OriginIndex.OriginC)
        For r = 1 To 27
            For c = 1 To 3
                If TempArray(r, c0 + c) = delete_number Then
                    If WorksheetFunction.RoundUp(r / 3, 0) <> r_index Then
                        TempArray(r, c0 + c) = 0
                    End If
                End If
            Next
        Next
    
    ' ３×３範囲。
        r0 = 9 * (WorksheetFunction.RoundUp(r_index / 3, 0) - 1)
        c0 = 9 * (WorksheetFunction.RoundUp(c_index / 3, 0) - 1)
        For r = 1 To 9
            For c = 1 To 9
                If TempArray(r0 + r, c0 + c) = delete_number Then
                    If WorksheetFunction.RoundUp((r + r0) / 3, 0) <> r_index Or _
                       WorksheetFunction.RoundUp((c + c0) / 3, 0) <> c_index Then
                        TempArray(r0 + r, c0 + c) = 0
                    End If
                End If
            Next
        Next
End Sub

Private Sub UniqueExistence()
    Dim r As Long, r2 As Long
    Dim c As Long, c2 As Long
    Dim arr As Variant
    Dim i As Long
        For r = 1 To 27
            ' １行スライスして、新たな配列を作成する。
            arr = WorksheetFunction.Index(TempArray, r, 0)
            ' この配列に１～９の値が幾つ含まれるか確認する。
            For i = 1 To 9
                ' 調査した値が一つしかない場合、確定可能。
                If ArrayCountIF(arr, i) = 1 Then
                    ' 一つしかなかった値の列番号を取得。
                    ' ※完全一致で取得しない場合、正しい結果にならない。要注意。
                    c = WorksheetFunction.Match(i, arr, 0)
                    ' ２７×２７の行列を、９×９に換算する。
                    r2 = WorksheetFunction.RoundUp(r / 3, 0)
                    c2 = WorksheetFunction.RoundUp(c / 3, 0)
                    ' 上記で求めたセルの値が未確定の場合、確定させる。
                    If FixedNumber(r2, c2) = 0 Then
                        FixedCell r2, c2, i
                    End If
                End If
            Next
        Next
        
        For c = 1 To 27
            ' １行スライスして、新たな配列を作成する。
            arr = WorksheetFunction.Index(TempArray, 0, c)
            ' この配列に１～９の値が幾つ含まれるか確認する。
            For i = 1 To 9
                ' 調査した値が一つしかない場合、確定可能。
                If ArrayCountIF(arr, i) = 1 Then
                    ' 一つしかなかった値の列番号を取得。
                    ' ※完全一致で取得しない場合、正しい結果にならない。要注意。
                    r = WorksheetFunction.Match(i, arr, 0)
                    ' ２７×２７の行列を、９×９に換算する。
                    r2 = WorksheetFunction.RoundUp(r / 3, 0)
                    c2 = WorksheetFunction.RoundUp(c / 3, 0)
                    ' 上記で求めたセルの値が未確定の場合、確定させる。
                    If FixedNumber(r2, c2) = 0 Then
                        FixedCell r2, c2, i
                    End If
                End If
            Next
        Next
        
        ' ２７×２７のうち、９等分した９×９の範囲について、一つしか存在しない
        ' 数を探す。もしあれば、その数でセルを確定させる。
        For r = 1 To 19 Step 9
            For c = 1 To 19 Step 9
                ' 配列をリサイズして、９×９の範囲を取得。
                arr = ResizeArray(TempArray, r, c, 9, 9)
                For i = 1 To 9
                    If ArrayCountIF(arr, i) = 1 Then
                        r2 = FindInArray(arr, i).Item(1)(0) + r - 1
                        c2 = FindInArray(arr, i).Item(1)(1) + c - 1
                        r2 = WorksheetFunction.RoundUp(r2 / 3, 0)
                        c2 = WorksheetFunction.RoundUp(c2 / 3, 0)
                        FixedCell r2, c2, i
                    End If
                Next
            Next
        Next
End Sub

' 元の配列から、指定位置を起点として、指定行数×指定列数を抜き出す。
Private Function ResizeArray(source_array As Variant, _
                             start_r_index As Long, _
                             start_c_index As Long, _
                             array_height As Long, _
                             array_width As Long) As Variant
    Dim arr() As Variant
    ReDim arr(1 To array_height, 1 To array_width)
    Dim r As Long
    Dim c As Long
        For r = 1 To array_height
            For c = 1 To array_width
                arr(r, c) = source_array(start_r_index + r - 1, _
                                         start_c_index + c - 1)
            Next
        Next
    
        ResizeArray = arr
End Function

' 指定配列内で指定値を全てコレクションに格納して返す。
Private Function FindInArray(source_array As Variant, _
                             faWhat As Long) As Collection
    Dim r As Long
    Dim c As Long
    Dim col As Collection
    Set col = New Collection
        For r = LBound(source_array, 1) To UBound(source_array, 1)
            For c = LBound(source_array, 2) To UBound(source_array, 2)
                If source_array(r, c) = faWhat Then
                    col.Add Array(r, c)
                End If
            Next
        Next
        Set FindInArray = col
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
    If i >= 2 Then
        ReDim Preserve arr(1 To i - 1)
    End If
    UnfixedArray = arr
End Function

' 最終解の正誤判定。
' 正・・・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

Public Sub GetAnswerArray()
    Dim arr(1 To 9, 1 To 9) As Variant
    Dim r As Long
    Dim c As Long
        For r = 1 To 9
            For c = 1 To 9
                If FixedNumber(r, c) <> 0 Then
                    arr(r, c) = FixedNumber(r, c)
                End If
            Next
        Next
        
        AnswerArray = arr
End Sub

Private Sub Class_Terminate()
    Dim Massage As String
        Select Case CheckAnswer
            Case True
                Massage = "完了！"
            Case False
                Massage = "断念！"
        End Select
        MsgBox Massage
        
    Application.StatusBar = False
End Sub

テストコードはこちら。

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

出題がこちら。今回のために、既存の設問を改造した。

解答の様子がこちら。
御覧の通り、黄色で塗りつぶされた箇所が、仮置きされたセルとなっている。

実は一行一列目の６が無いと、このSudokuクラスでは解ききれない。
さらに、一行五列目の１があれば、総当たりすら必要ない。
たった２枚の有無で、ここまで違いが出るから驚きだ。

結局最後まで自動で解ききることは叶わなかったが、半年前より前進したので良しとしよう。

何か思いついたら、再々挑戦するかも。
ということで、今回のシリーズは、これでおしまいです。

参考まで。