数独（再挑戦）⑤ 計算の途中結果を見える化（寄り道）

昨日は、数独の計算結果をセルに戻すことに挑戦した。
infoment.hatenablog.com

すると、一回ずつ貼り付けて経過を見てみるという案を、コメントでいただいた（いつも有難うございます）。

そこで、今回はちょっと寄り道。計算の途中結果を見える化してみよう。

まず、Public変数で設定していたSourceArrayを改め、以下の二つを追加した。

• SourceRange　出題範囲受け取り用
• DestinationRange　解答貼り付け用

クラスモジュール（Sudoku）

Option Explicit
' 出題された９×９の範囲。
Public SourceRange As Range
' 解答を張り付ける範囲。
Public DestinationRange As Range
' 出題された９×９を格納する配列。
Private Property Get SourceArray() As Variant
    SourceArray = SourceRange.Value
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, 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
End Sub

一巡するたびに、その結果を張り付ける。一瞬で終わらないよう、張り付けるたびに１秒停止。

Public Sub SetAnswer()
    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
            
            ' --------------↓↓今回追加↓↓--------------
            ' 一巡したところで解答取得。
            GetAnswerArray
            
            ' 解答貼り付け範囲に、解答を格納した配列を貼り付け。
            DestinationRange = AnswerArray
            
            ' １秒待つ。
            Application.Wait Now + TimeValue("0:00:01")
            ' --------------↑↑今回追加↑↑--------------
            
            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
End Sub

ついでに、終了メッセージも作成してみた。クラスを破棄する際に、メッセージを表示させる。

Private Sub Class_Terminate()
    Select Case WorksheetFunction.CountBlank(DestinationRange)
        Case 0
            MsgBox "完了！"
        Case Else
            MsgBox "断念！"
    End Select
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

結果はこちら。

明日に続きます。

参考まで。