数独（再挑戦）④ ２７×２７を９×９に戻す - Infomentのブログ～Excel VBA奮闘記～

昨日は、数独を解くマクロに於いて、確定マスの情報を行と列全体に反映させてみた。
infoment.hatenablog.com

今日は、その結果を９×９に戻して、シートに貼り付けてみる。
f:id:Infoment:20191203220213p:plain

実は昨日、「行と列全体」と言いつつ、一部しか反映していない。

行全体　済
列全体　未
３×３　未

そこでまず、昨日の「DeleteNumber」を完成させる。

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

計算を繰り返して、もうループの前後で変化が無くなったら、諦めて解答用配列を作成しよう。昨日のUpdateArrayに、そのためのサブルーチン呼び出しを一行追加する。

Public Sub UpdateArray()

    Dim r As Long
    Dim c As Long
    Dim n As Long
    Dim SumAll As Long
    Dim counter As Long
    
        ' 編集の有無を確認するために、予め配列の合計値を求めておく。
        ' ※何らかの編集があれば、１以上の値が０に置き換わり、合計も変わる。
        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
            
            If SumAll = WorksheetFunction.Sum(TempArray) Then
                Exit Do
            Else
                SumAll = WorksheetFunction.Sum(TempArray)
            End If
            
            ' 念のため、仮の措置として、１００回繰り返したらループを抜ける。
            counter = counter + 1
            If counter >= 100 Then Exit Do
        Loop
        
        ' 今回追加。
        GetAnswerArray

End Sub

それでは最後に、解答用配列を作成しよう。２７×２７の配列のうち、確定した数値を９×９の配列へ格納する。

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

テスト用コードがこちら。

Sub test()
    Dim Sudoku As New Sudoku
        Sudoku.SourceArray = Sheet1.Range("A1:I9").Value
        Sudoku.InitArray
        Sudoku.UpdateArray

        ' 結果を貼り付け。
        Sheet1.Range("K1").Resize(9, 9) = Sudoku.AnswerArray
End Sub