数独をExcelのVBAで解くのをやってみた

sudoku-dict.vba

Option Explicit

Private Const ScreenUpdate As Boolean = False

Private TryCounter As Long

' 行／列／グループ（枠）それぞれの内に数字が存在するかどうかを疑似連想配列で管理
Private RowDictArray(1 To 9, 1 To 9) As Long
Private ColumnDictArray(1 To 9, 1 To 9) As Long
Private GroupDictArray(1 To 9, 1 To 9) As Long


Sub main()
    Dim NumberMatrix() As Long
    Dim StartTime As Double
    Dim EndTime As Double
    Dim ElapsedTimeString As String
    
    TryCounter = 0
    
    If Not InitSudoku(NumberMatrix) Then
        MsgBox "不正な問題"
        Exit Sub
    End If

    Range("H10").Value = ""
    Range("C10").Value = ""

    StartTime = Timer
    Debug.Print StartTime
    
    TrySudoku NumberMatrix
    
    EndTime = Timer
    Debug.Print EndTime
  
    Range("A1:I9").Value = NumberMatrix
    
    ElapsedTimeString = Format((EndTime - StartTime), "0.00")
    Debug.Print "疑似連想配列使用版: " & TryCounter & "回試行・" & ElapsedTimeString & "秒経過"
    
    Range("C10").Value = TryCounter
    Range("H10").Value = ElapsedTimeString
    
    If CheckNumberMatrix(NumberMatrix) = 0 Then
        MsgBox "解読成功" & vbLf & TryCounter
    Else
        MsgBox "あれれ・・・"
    End If
End Sub

Function InitSudoku(ByRef NumberMatrix() As Long) As Boolean
    Application.ScreenUpdating = False
    
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim SourceValueArray() As Variant
    Dim RemainBlankNumber As Long
    Dim ErrorInfos() As Variant
    Dim ErrorIndex As Long
    
    InitSudoku = True
    
    ReDim NumberMatrix(1 To 9, 1 To 9)
    
    SourceValueArray = Range("A1:I9").Value
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            If SourceValueArray(RowNumber, ColumnNumber) = 0 Or Cells(RowNumber, ColumnNumber).Font.Color = vbBlue Then
                Cells(RowNumber, ColumnNumber).Value = ""
                Cells(RowNumber, ColumnNumber).Font.Color = vbBlue
            Else
                NumberMatrix(RowNumber, ColumnNumber) = Cells(RowNumber, ColumnNumber).Value
                Cells(RowNumber, ColumnNumber).Font.Color = vbBlack
            End If
        Next ColumnNumber
    Next RowNumber
    
    RemainBlankNumber = InitNumberMatrix(NumberMatrix, ErrorInfos)
    
    If 0 < UBound(ErrorInfos) Then
        For ErrorIndex = 1 To UBound(ErrorInfos)
            Cells(ErrorInfos(ErrorIndex)(0), ErrorInfos(ErrorIndex)(1)).Font.Color = vbRed
            Cells(ErrorInfos(ErrorIndex)(2), ErrorInfos(ErrorIndex)(3)).Font.Color = vbMagenta
        Next ErrorIndex
        
        InitSudoku = False
    End If

    Application.CutCopyMode = False
    Range("A10").Select
    
    Application.ScreenUpdating = True
End Function

Function TrySudoku(ByRef NumberMatrix() As Long) As Boolean
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim Index As Long
    Dim RemainNumbers() As Long
    Dim TryNumber As Long

    If Not GetBlankPosition(NumberMatrix, RowNumber, ColumnNumber, RemainNumbers) Then
        TrySudoku = True
        Exit Function
    End If

    For Index = 1 To UBound(RemainNumbers)
        TryNumber = RemainNumbers(Index)
        
        UpdateNumberMatrix NumberMatrix, RowNumber, ColumnNumber, TryNumber
        If ScreenUpdate Then Cells(RowNumber, ColumnNumber) = TryNumber
                
        TryCounter = TryCounter + 1
        
        If TrySudoku(NumberMatrix) = True Then
            TrySudoku = True
            Exit Function
        End If
    Next
    
    UpdateNumberMatrix NumberMatrix, RowNumber, ColumnNumber, 0
    If ScreenUpdate Then
        Cells(RowNumber, ColumnNumber) = ""
        DoEvents
    End If
    TrySudoku = False
End Function

Function CheckNumberMatrix(ByRef NumberMatrix() As Long) As Long
    Dim ErrorInfos() As Variant
    Dim ErrorIndex As Long
    
    CheckNumberMatrix = InitNumberMatrix(NumberMatrix, ErrorInfos)
    
    If UBound(ErrorInfos) <= 0 Then
        Exit Function
    End If
    
    CheckNumberMatrix = -1
    For ErrorIndex = 1 To UBound(ErrorInfos)
        Cells(ErrorInfos(ErrorIndex)(0), ErrorInfos(ErrorIndex)(1)).Font.Color = vbRed
        Cells(ErrorInfos(ErrorIndex)(2), ErrorInfos(ErrorIndex)(3)).Font.Color = vbMagenta
    Next ErrorIndex
End Function

Function GetBlankPosition(ByRef NumberMatrix() As Long, ByRef TargetRowNumber As Long, ByRef TargetColumnNumber As Long, ByRef RemainNumbers() As Long) As Boolean
    Dim RemainNumbersMatrix(1 To 9, 1 To 9) As Long
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim CheckRowNumber As Long
    Dim CheckColumnNumber As Long
    Dim CheckGroupItemNumber As Long
    Dim NumberValue As Long
    Dim Point As Long
    Dim MinPoint As Long
    Dim RemainNumberCounter As Long
    Dim NumberIndex As Long
    
    TargetRowNumber = 0
    TargetColumnNumber = 0
    ReDim RemainNumbers(0)
    
    GetBlankPosition = False
    
    For ColumnNumber = 1 To 9
        For RowNumber = 1 To 9
            RemainNumberCounter = 0
            If NumberMatrix(RowNumber, ColumnNumber) = 0 Then
                PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
                
                For NumberValue = 1 To 9
                    If _
                        RowDictArray(RowNumber, NumberValue) = 0 And _
                        ColumnDictArray(ColumnNumber, NumberValue) = 0 And _
                        GroupDictArray(GroupNumber, NumberValue) = 0 _
                    Then
                        RemainNumberCounter = RemainNumberCounter + 1
                    End If
                Next NumberValue
            End If
            RemainNumbersMatrix(RowNumber, ColumnNumber) = RemainNumberCounter
        Next RowNumber
    Next ColumnNumber
    
    MinPoint = 9999
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            If NumberMatrix(RowNumber, ColumnNumber) = 0 Then
                Point = 1000 * RemainNumbersMatrix(RowNumber, ColumnNumber)
                
                PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
                
                For CheckColumnNumber = 1 To 9
                    If CheckColumnNumber <> ColumnNumber Then
                        If 0 < RemainNumbersMatrix(RowNumber, CheckColumnNumber) Then Point = Point + 1
                        'Point = Point + RemainNumbersMatrix(RowNumber, CheckColumnNumber)
                    End If
                Next
                
                For CheckRowNumber = 1 To 9
                    If CheckRowNumber <> RowNumber Then
                        If 0 < RemainNumbersMatrix(CheckRowNumber, ColumnNumber) Then Point = Point + 1
                        'Point = Point + RemainNumbersMatrix(CheckRowNumber, ColumnNumber)
                    End If
                Next
                
                For CheckGroupItemNumber = 1 To 9
                    GroupToPosition GroupNumber, CheckGroupItemNumber, CheckRowNumber, CheckColumnNumber
                    If CheckRowNumber <> RowNumber And CheckColumnNumber <> ColumnNumber Then
                        If 0 < RemainNumbersMatrix(CheckRowNumber, CheckColumnNumber) Then Point = Point + 1
                        'Point = Point + RemainNumbersMatrix(CheckRowNumber, CheckColumnNumber)
                    End If
                Next
                
                If Point < MinPoint Then
                    TargetRowNumber = RowNumber
                    TargetColumnNumber = ColumnNumber
                    MinPoint = Point
                End If
            End If
        Next ColumnNumber
    Next RowNumber

    If MinPoint < 9999 Then
        PositionToGroup TargetRowNumber, TargetColumnNumber, GroupNumber, GroupItemNumber
        For NumberValue = 1 To 9
            If _
                RowDictArray(TargetRowNumber, NumberValue) = 0 And _
                ColumnDictArray(TargetColumnNumber, NumberValue) = 0 And _
                GroupDictArray(GroupNumber, NumberValue) = 0 _
            Then
                ReDim Preserve RemainNumbers(UBound(RemainNumbers) + 1)
                RemainNumbers(UBound(RemainNumbers)) = NumberValue
            End If
        Next NumberValue
        
        GetBlankPosition = True
    End If
End Function

Sub UpdateNumberMatrix(ByRef NumberMatrix() As Long, ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByVal NumberValue As Long)
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim OldNumberValue As Long
    
    PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
    
    OldNumberValue = NumberMatrix(RowNumber, ColumnNumber)
    
    If 0 < OldNumberValue Then
        RowDictArray(RowNumber, OldNumberValue) = 0
        ColumnDictArray(ColumnNumber, OldNumberValue) = 0
        GroupDictArray(GroupNumber, OldNumberValue) = 0
    End If
    
    If 0 < NumberValue Then
        RowDictArray(RowNumber, NumberValue) = ColumnNumber
        ColumnDictArray(ColumnNumber, NumberValue) = RowNumber
        GroupDictArray(GroupNumber, NumberValue) = GroupItemNumber
    End If

    NumberMatrix(RowNumber, ColumnNumber) = NumberValue
End Sub

Function InitNumberMatrix(ByRef NumberMatrix() As Long, ByRef ErrorInfos() As Variant) As Long
    Dim Index As Long
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim NumberValue As Long
    Dim ExistRowNumber As Long
    Dim ExistColumnNumber As Long
    
    InitNumberMatrix = 9 * 9
    
    ReDim ErrorInfos(0)
    
    For Index = 1 To 9
        For NumberValue = 1 To 9
            RowDictArray(Index, NumberValue) = 0
            ColumnDictArray(Index, NumberValue) = 0
            GroupDictArray(Index, NumberValue) = 0
        Next NumberValue
    Next Index
    
    For ColumnNumber = 1 To 9
        For RowNumber = 1 To 9
            NumberValue = NumberMatrix(RowNumber, ColumnNumber)

            If NumberValue <> 0 Then
                If RowDictArray(RowNumber, NumberValue) Then
                    ExistRowNumber = RowNumber
                    ExistColumnNumber = RowDictArray(RowNumber, NumberValue)
                ElseIf ColumnDictArray(ColumnNumber, NumberValue) Then
                    ExistRowNumber = ColumnDictArray(ColumnNumber, NumberValue)
                    ExistColumnNumber = ColumnNumber
                Else
                    PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber

                    If GroupDictArray(GroupNumber, NumberValue) Then
                        GroupToPosition GroupNumber, GroupDictArray(GroupNumber, NumberValue), ExistRowNumber, ExistColumnNumber
                    Else
                        ExistRowNumber = 0
                        ExistColumnNumber = 0

                        RowDictArray(RowNumber, NumberValue) = ColumnNumber
                        ColumnDictArray(ColumnNumber, NumberValue) = RowNumber
                        GroupDictArray(GroupNumber, NumberValue) = GroupItemNumber

                        InitNumberMatrix = InitNumberMatrix - 1
                    End If
                End If

                If 0 < ExistRowNumber Then
                    ReDim Preserve ErrorInfos(UBound(ErrorInfos) + 1)
                    ErrorInfos(UBound(ErrorInfos)) = Array(RowNumber, ColumnNumber, ExistRowNumber, ExistColumnNumber, NumberValue)
                End If
            End If
        Next RowNumber
    Next ColumnNumber
End Function

Sub PositionToGroup(ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByRef GroupNumber As Long, ByRef GroupItemNumber As Long)
    GroupNumber = Int((RowNumber + 2) / 3) + 3 * (Int((ColumnNumber + 2) / 3) - 1)
    GroupItemNumber = 1 + ((RowNumber + 2) Mod 3) + 3 * ((ColumnNumber + 2) Mod 3)
End Sub

Sub GroupToPosition(ByVal GroupNumber As Long, ByVal GroupItemNumber As Long, ByRef RowNumber As Long, ByRef ColumnNumber As Long)
    RowNumber = 1 + 3 * ((GroupNumber - 1) Mod 3) + ((GroupItemNumber - 1) Mod 3)
    ColumnNumber = 1 + 3 * Int((GroupNumber - 1) / 3) + Int((GroupItemNumber - 1) / 3)
End Sub

きっかけ

はけた氏のツイート経由で、

数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1｜VBAサンプル集

を見て、面白そうだったので、自分なりに書き下してみた。

エクセルのサンプルダウンロード｜エクセルの神髄

からダウンロードできる数独のエクセルファイル中のVBAを差し替えることで試用可能。

そのままだと面白くないので、

• 行／列／グループ（枠）それぞれの内に数字が存在するかどうかを連想配列で管理
• ↑の状態は初期化時に全セルをチェックし、その後は変化したセルに対してのみ書き換え

するようにしてみた。

とりあえず素直に、CreateObject("Scripting.Dictionary") を使ってみる……

https://gist.github.com/furyutei/192911043d16f4793c7f21655482aca1/444b3bf5dc68356fb14e296efde438bbfd6f465c

すると……元のコードと比べ、パフォーマンスが大幅に落ちてしまった(苦笑)。
※セルの更新を表示しないようにした状態で、4～5倍程度時間がかかってしまう。

CreateObject("Scripting.Dictionary") による連想配列がボトルネックっぽいなぁ……とアタリをつけて、その部分だけ単純な配列を疑似的な連想配列となるように使って置換。

https://gist.github.com/furyutei/192911043d16f4793c7f21655482aca1/1e6ac8b073952ab2eb0450f7fd77e643e435f3c4

元のコードと同等か少し落ちる程度のパフォーマンスは出るようにはなった（669回の試行で1.38秒→0.28秒とか）。

が……連想配列を使うことで元のコードにあるchkSu()相当処理の簡略化や、地味にループ回数を減らしたりしているのにパフォーマンスが上がらないということは、それを補って余りあるボトルネックがあるわけで……どこだ……少し時間を置いてから見直してみよう。　　

直感で、行列←→グループ（枠）の座標変換関数がボトルネックになっている気がしたので、計算を省いてショートカットするようにしてみた。

https://gist.github.com/furyutei/192911043d16f4793c7f21655482aca1/ceeee5dc9ddde4f27ad37771fdbef305c8894c3b

当たりだったっぽい。
総合的に、元のコードよりも約1割前後の速度向上が見られる模様。　　

なお、現時点ではコアとなるアルゴリズムは変更していないため、試行回数と結果は元のコードと同じになる（空きセル選択方法を微妙に調整していた名残もあるが……）。

数値があるかどうかをフラグ（ビット演算）で管理する版も置いておく。

• 変数宣言
• 初期化
• 判定1・判定2→判定1・判定2
• 状態更新

辺りで使用。

'\'演算子は、Mac版Excelに持って行ったときに問題がでる可能性を指摘されたので、Fix()を使用するように修正。

数値を設定する毎に、次に設定可能な値等の状態を履歴で保存するようにした版を作成。
参考：suudoku/suudoku11.bas at master · m-haketa/suudoku