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

Excel VBA 作ってみた クラスモジュール ユーザー定義関数 算数パズル

昨日は、数独をＶＢＡで解くための前段として、どのような形で解析すれば良いかについて検討してみた。
infoment.hatenablog.com
そこで今日からは、実際に解を求めるべく、コードの作成に挑戦する。
f:id:Infoment:20190503223647p:plain

今回は、数独解析用に「Sudoku」クラスを作成した。
また、コメントを解説に変えているため、通常は無いほどの過剰コメントとなっている。

クラスモジュール（Sudoku）

モジュールレベル変数。

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

クラスの初期化。

Private Sub Class_Initialize()
    ' 画面更新の一時停止。
    Application.ScreenUpdating = False
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

さて、ここからは各マスについて、どの値が入るのか入らないのか、一つずつ確認していく。確認する範囲は、以下の３通りだ。

  1. 行方向（９マス）
  2. 列方向（９マス）
  3. 所属する小範囲（３×３＝９マス）

f:id:Infoment:20190503230735p:plain

例えば、（５，５）は空欄であるため、ここに入りうる数値を考えてみる。
f:id:Infoment:20190503231300p:plain

行方向
１，３，４，８は空欄であるため、該当する桁は０となる。
f:id:Infoment:20190503231538p:plain

列方向
同様に、列方向について確認する。
f:id:Infoment:20190503231742p:plain

小範囲
最後に、小範囲で確認する。
f:id:Infoment:20190503231928p:plain

ここまで３回のチェックの中で、重複している数値が幾つかある。しかし、重複はこの際無視して、とにかく存在すれば０にする。

今回の例では確認の結果、５以外は全て０（＝その数字になり得ないことが確定）となった。そこで、１０桁の中に０が幾つあるか数えたくなったので、こちらの関数を作成した。

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

以上をサブプロシージャに落とし込んだのが、↓ こちら。

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
        End If
        
        ArrAll(r_target, c_target) = Join(v, vbNullString)
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
End Sub

最後に、こちらで貼り付けなどを行う。

Private Sub Class_Terminate()
    TableRange = ArrNum
    TableRange.Replace 0, vbNullString
    Application.ScreenUpdating = True
End Sub
標準モジュール

こちらでは、範囲をセットして解析を実行するだけ。

Sub 数独()
    Dim SDK As Sudoku
    Set SDK = New Sudoku
        SDK.init Range("A1:I9")
        SDK.Analize
End Sub

先のサンプルで試してみると、５回の繰り返しで解析が完了した。
f:id:Infoment:20190503233211g:plain

勿論、これだけで全ての問題が解けるわけではない。実際、現時点で解けるのは「入門編」レベルまで。某サイトの「初級編」すら、最終解に至ることができなかった。ここから更に、幾つかのロジックを追加する必要がある。



ということで、明日に続きます。

参考まで。