数独をＶＢＡで解いてみる ④

昨日は、数独をＶＢＡで解くコードに新たなロジックを追加してみた。
infoment.hatenablog.com
今日は、答えが出るまで繰り返し処理を行わせることに挑戦する。

単純に繰り返すなら、For ~ Next ループが手っ取り早い。

Sub Sample()
    Dim i As Long
        For i = 1 To 10
            Call 何某かの処理
        Next
End Sub

この方法の場合、ループ変数ｉは、何某かの処理と全く無関係でも構わない。でも今回は、再帰呼び出しで行ってみた。
まず、総処理数を数えるために、カウンターを一つ準備する。加えて、最大処理数用にも変数を準備。

' モジュールレベル変数
' Analizeの処理回数カウント用。
Dim TotalCounter As Long
' 最大処理数。
Dim MaxTry As Long

これらの変数は、クラスモジュールの初期化時に初期設定する。

Private Sub Class_Initialize()
    ' 画面更新の一時停止。
    Application.ScreenUpdating = False

    ' 今回追加個所。
    TotalCounter = 0
    MaxTry = 100
End Sub

解析用モジュールに、再帰呼び出し箇所を追加。

Public Sub Analize()
    Dim r As Long
    Dim c As Long
        For r = 1 To 9
            For c = 1 To 9
                CheckNumber r, c
            Next
        Next
        
        ' 今回追加個所。
        ' 最大処理数に達していた場合、処理終了。
        If TotalCounter = MaxTry Then
            Exit Sub
        End If
        
        ' マスに一つでも０があれば、つまり未解決のマスが
        ' 一つでもある場合、再帰呼び出しで処理を行う。
        For r = 1 To 9
            For c = 1 To 9
                If ArrNum(r, c) = 0 Then
                    TotalCounter = TotalCounter + 1
                    Call Analize
                    Exit Sub
                End If
            Next
        Next
End Sub

最後に、処理回数の表示を追加する。

Private Sub Class_Terminate()
    TableRange = ArrNum
    TableRange.Replace 0, vbNullString
    Application.ScreenUpdating = True
    
    ' 今回追加個所。
    If TotalCounter = MaxTry Then
        MsgBox "試行が規定回数（" & MaxTry & "回）に達したため、処理を中断します。"
    Else
        MsgBox "繰り返し回数：" & TotalCounter
    End If
End Sub

以上を組み込んだところまでで、某サイトの問題を解いてみると、中級編まではほぼ問題なく全てのマスを埋めることが出来るようになった。

しかし現時点では、まだまだ上級レベルには太刀打ちできない。

◆今回までのソースコードまとめ（クリックで展開）◆

Option Explicit

' 各マスの情報を表した１０桁の数（文字列）を格納するための配列。
Dim ArrAll(1 To 9, 1 To 9) As Variant
' 各マスの数値。
Dim ArrNum(1 To 9, 1 To 9) As Variant
' シート上の９×９の範囲。
Dim TableRange As Range
' Analizeの処理回数カウント用。
Dim TotalCounter As Long
' 最大処理数。
Dim MaxTry As Long

Private Sub Class_Initialize()
    ' 画面更新の一時停止。
    Application.ScreenUpdating = False
    TotalCounter = 1
    MaxTry = 100
End Sub

' 初期設定。
Public Sub init(table_range As Range)
    
    ' ９×９マスの範囲設定。
    Set TableRange = table_range
    
    ' 初期値が空欄のマスは、分かり易くするため文字色を赤に変更。
    Dim rng As Range
        For Each rng In TableRange
            If rng = vbNullString Then
                rng.Font.Color = 192
            Else
                rng.Font.Color = vbBlack
            End If
        Next
    
    ' 配列の初期値をセット。
    ' ArrAllは、各マスにどの数字が入るか入らないかを格納する。
    ' 各値は１０桁の数値で構成されており、各桁は０～２の値をとる。
    ' ※０桁目は、数値の確定状況を表し、１～９桁目は数値が入るか
    ' 　入らないかを表している。
    ' 　０：入らない（確定），１：入る（確定），２：未定。
    ' 従って、空欄の初期値は２２２２２２２２２２となる。
    Dim r As Long
    Dim c As Long
    Dim i As Long
    Dim v(9) As Variant
        For r = 1 To 9
            For c = 1 To 9
                If table_range.Cells(r, c) = vbNullString Then
                    ArrAll(r, c) = "2222222222"
                    ' 便宜上、空欄のマスには０をセットする。
                    ArrNum(r, c) = 0
                Else
                    v(0) = 1
                    For i = 1 To 9
                        If i = table_range.Cells(r, c) Then
                            v(i) = 1
                        Else
                            v(i) = 0
                        End If
                    Next
                    ArrAll(r, c) = Join(v, vbNullString)
                    ArrNum(r, c) = table_range.Cells(r, c)
                End If
            Next
        Next
End Sub

Public Sub Analize()
    Dim r As Long
    Dim c As Long
        For r = 1 To 9
            For c = 1 To 9
                CheckNumber r, c
            Next
        Next
        
        ' 最大処理数に達していた場合、処理終了。
        If TotalCounter = MaxTry Then
            Exit Sub
        End If
        
        ' マスに一つでも０があれば、つまり未解決のマスが
        ' 一つでもある場合、再帰呼び出しで処理を行う。
        For r = 1 To 9
            For c = 1 To 9
                If ArrNum(r, c) = 0 Then
                    TotalCounter = TotalCounter + 1
                    Call Analize
                    Exit Sub
                End If
            Next
        Next
End Sub

Private Sub CheckNumber(r_target As Long, c_target As Long)
    ' 確定マスの場合、処理終了。
    If Left(ArrAll(r_target, c_target), 1) = 1 Then Exit Sub
    
    Dim r As Long
    Dim c As Long
    Dim v(9) As Variant
    Dim i As Long
    
        ' 各桁置き換え用に、一旦配列化する。
        For i = 0 To 9
            v(i) = Mid(ArrAll(r_target, c_target), i + 1, 1)
        Next
        
    
    ' 行方向確認。
    Dim index As Long
        For c = 1 To 9
            index = ArrNum(r_target, c)
            If index <> 0 Then
                v(index) = 0
            End If
        Next
        
    ' 列方向確認。
        For r = 1 To 9
            index = ArrNum(r, c_target)
            If index <> 0 Then
                v(index) = 0
            End If
        Next
    
    ' ３×３範囲確認。
    Dim sr As Long
        sr = WorksheetFunction.RoundUp(r_target / 3, 0) * 3 - 2
    Dim sc As Long
        sc = WorksheetFunction.RoundUp(c_target / 3, 0) * 3 - 2
        For r = sr To sr + 2
            For c = sc To sc + 2
                index = ArrNum(r, c)
                If index <> 0 Then
                    v(index) = 0
                End If
            Next
        Next
        
        ' ０の数が８個ならば、残った数で確定。
        If CountNumber(v, 0) = 8 Then
            v(0) = 1
            For i = 1 To 9
                If v(i) <> 0 Then
                    v(i) = 1
                    Exit For
                End If
            Next
            ArrNum(r_target, c_target) = i
        
        Else
            Dim j As Long
                For j = 1 To 9
                    If GetNumber(r_target, c_target, j) <> 0 Then
                        For i = 0 To 9
                            Select Case i
                                Case 0: v(i) = 1
                                Case j: v(i) = 1
                                Case Else: v(i) = 0
                            End Select
                        Next
                        ArrNum(r_target, c_target) = j
                        Exit For
                    End If
                Next
        End If
        
        ArrAll(r_target, c_target) = Join(v, vbNullString)
End Sub

Private Function CountNumber(arr As Variant, target_number As Long) As Long
    Dim i As Long
    Dim counter As Long
        For i = 1 To 9
            If arr(i) = target_number Then
                counter = counter + 1
            End If
        Next
        
        CountNumber = counter
End Function

Private Function GetNumber(r_target, c_target, index) As Long

    Dim r As Long
    Dim c As Long
    Dim v(1 To 9) As Variant
    
    ' 行方向確認。
    ' 各マスの指定数を配列に格納。
        For c = 1 To 9
            v(c) = Mid(ArrAll(r_target, c), index + 1, 1)
        Next
    
    ' 指定マス指定数のフラグが２（＝未確定）であって、且つ
    ' 配列内の０の数が８であれば、そのマスの値はindexで確定する。
        If CountNumber(v, 0) = 8 And v(c_target) = 2 Then
            GetNumber = index
            Exit Function
        End If
        
    ' 列方向確認。以下、同様。
        For r = 1 To 9
            v(r) = Mid(ArrAll(r, c_target), index + 1, 1)
        Next
        
        If CountNumber(v, 0) = 8 And v(r_target) = 2 Then
            GetNumber = index
            Exit Function
        End If
        
    ' ３×３範囲確認。
    Dim sr As Long
        sr = WorksheetFunction.RoundUp(r_target / 3, 0) * 3 - 2
    Dim sc As Long
        sc = WorksheetFunction.RoundUp(c_target / 3, 0) * 3 - 2
    Dim i As Long
        i = 1
        For r = sr To sr + 2
            For c = sc To sc + 2
                v(i) = Mid(ArrAll(r, c), index + 1, 1)
                i = i + 1
            Next
        Next
        
    Dim myIndex As Long
        myIndex = (r_target - sr) * 3 + (c_target - sc) + 1
    
        If CountNumber(v, 0) = 8 And v(myIndex) = 2 Then
            GetNumber = index
        End If

End Function

Private Sub Class_Terminate()
    TableRange = ArrNum
    TableRange.Replace 0, vbNullString
    Application.ScreenUpdating = True

    If TotalCounter = MaxTry Then
        MsgBox "試行が規定回数（" & MaxTry & "回）に達したため、処理を中断します。"
    Else
        MsgBox "繰り返し回数：" & TotalCounter
    End If
End Sub

次回に続きます。

参考まで。