数独250問を0.2秒で解析する高速VBAコード
数独解析の高速化を最優先にしているため、一般的なコードの記述と異なる部分が多くあります。

このページで紹介している、数独を解析する AnalyzeSudoku 関数を利用している処理の例です。

・一意・複数解判定

・9×9の解答作成

・既存の問題難度向上

'----------------------------------------------------------------------------
' 数独解析モジュール version 3.0.3［作成日］2010.08.30 ［更新日］2024.05.01
'----------------------------------------------------------------------------
' ■ 数独を解析する関数
'
'［構文］AnalyzeSudoku(ByRef Array2dData As Variant, _
'                      ByRef ErrorMessage As String, _
'                      Optional ByVal AscDesc As Boolean = True) As Long
'
'［引数］
'   Array2dData ：数独の問題が格納されている2次元配列(1 To 9,1 To 9)を指定
'                 解析結果はこの引数 Array2dData に格納される
'   ErrorMessage：解析時にエラー起きた場合、エラー内容が格納される
'   AscDesc     ：解析で候補値を昇順・降順のどちらから仮置きするかの設定
'                 小さい数値から仮置きする場合は「True」
'
'［戻り値］
'              0：解析の成功
'          1以上：エラー エラー内容は引数ErrorMessageに格納される
'
'■ 使用例　セル[A1:I9]の数値を基に解析を行い、結果をセル[A11:I19]に設定
'
'   Sub ExampleOfUse_AnalyzeSudoku()
'      ' 変数にセル[A1:I9]の値を代入
'      Dim varArea    As Variant
'      varArea = Range("A1:I9").Value
'
'      ' 解析
'      Dim strMessage As String
'      If AnalyzeSudoku(varArea, strMessage, False) <> 0 Then
'          MsgBox strMessage, vbExclamation + vbOKOnly
'          Exit Sub
'      End If
'
'      ' 解析結果をセル[A11:I19]に代入
'      Range("A11:I19").Value = varArea
'   End Sub
'----------------------------------------------------------------------------
Option Explicit

'-----------------------------------
' モジュール変数
'-----------------------------------
Private pr_lngArray2dData()          As Long                ' 結果格納用
Private pr_lngReferenceValue(1 To 9) As Long                ' 3×3エリアの基準行/列格納用
Private pr_blnAscDesc                As Boolean             ' 仮置き昇順降順フラグ、
Private pr_blnCompleted              As Boolean             ' 解析終了フラグ

'-----------------------------------
' 構造体
'-----------------------------------
' 候補値情報
Private Type CandidateInfomation
    Flg(1 To 9)                      As Boolean             ' 候補数値フラグ
    RemoveFlg                        As Boolean             '「RemoveFromCandidateValues」実行確認フラグ
End Type

' 階層情報
Private Type HierarchyInformation
    Array2dData()                    As Long                ' 数独問題、解析過程、結果を格納
    CandidateInfo()                  As CandidateInfomation ' 候補値情報
    ConfirmationFlg                  As Boolean             ' 「GetSquareInfoWithTheMinimumCandidateValue」実行確認フラグ
    Blank                            As Long                ' 空白マス数
    NumberOfExecutions               As Long                ' 仮置き実行回数
    MinRow                           As Long                ' 候補値数最小マスの行格納
    MinColumn                        As Long                ' 候補値数最小マスの列格納
    MinCandidateValue()              As Long                ' 候補値数最小マスの候補値格納
    Number                           As Long                ' 候補値数最小マス候補値数
End Type

'---------------------------------------------------------------------------
' 数独を解析する関数
'---------------------------------------------------------------------------
Function AnalyzeSudoku(ByRef Array2dData As Variant, _
                       ByRef ErrorMessage As String, _
                       Optional ByVal AscDesc As Boolean = True) As Long
On Error GoTo LBL_ERROR
    pr_blnCompleted = False
    pr_blnAscDesc = AscDesc
    ' 事前準備
    Dim typHierarchyInfo As HierarchyInformation
    If AdvancePreparation(typHierarchyInfo, Array2dData) Then AnalyzeSudoku = 1: GoTo LBL_ERROR
    ' 解析メイン処理実行
    If AnalysisMainProcessing(typHierarchyInfo) Then Else AnalyzeSudoku = 2: GoTo LBL_ERROR
    Array2dData = pr_lngArray2dData
On Error GoTo 0
    Exit Function
LBL_ERROR:
    Dim varError As Variant
    varError = Array("解析に失敗しました", "既に全てのマスが埋まっています", "この問題は解析不可能です")
    ErrorMessage = varError(AnalyzeSudoku)
    If AnalyzeSudoku = 0 Then AnalyzeSudoku = 3
End Function

' 事前準備
Private Function AdvancePreparation(ByRef typH As HierarchyInformation, ByRef Array2dData As Variant) As Boolean
    Dim i As Long, j As Long, v As Variant, typCandidate As CandidateInfomation
    For i = 1 To 9
        typCandidate.Flg(i) = True
        pr_lngReferenceValue(i) = ((i - 1) \ 3) * 3 + 1               ' (1 To 9)=1,1,1,4,4,4,7,7,7
    Next
    With typH
        ReDim .Array2dData(1 To 9, 1 To 9), .CandidateInfo(1 To 9, 1 To 9)
        For i = 1 To 9
            For j = 1 To 9
                v = Array2dData(i, j)
                If IsError(v) Then v = Empty                          ' エラー値はEmptyに変換
                Select Case v
                    Case 1 To 9                                       ' 数値1～9
                        .Array2dData(i, j) = CLng(v)
                        .CandidateInfo(i, j).Flg(CLng(v)) = True
                    Case Else                                         ' それ以外の値
                        .CandidateInfo(i, j) = typCandidate
                        .Blank = .Blank + 1                           ' 空白数カウント
                End Select
            Next
        Next
        AdvancePreparation = CBool(.Blank = 0)                        ' 空白がなければエラー
    End With
End Function

' 解析メイン処理関数（再帰関数）
Private Function AnalysisMainProcessing(ByRef typH As HierarchyInformation) As Boolean
    Dim lngCheckBlank As Long, typCH As HierarchyInformation
    With typCH                                                        ' 上の階層のtypHからカレント階層に値を引き継ぎ
        .CandidateInfo = typH.CandidateInfo                           ' 候補値情報
        .Array2dData = typH.Array2dData                               ' 問題・解析状況
        .Blank = typH.Blank                                           ' 空白数
        '--------------------
        ' 解析第一段階
        '--------------------
        Call AnalysisFirstStage(typCH)
        Do
            lngCheckBlank = .Blank
            If CheckCandidateValues(typCH) Then Exit Function         ' 候補値チェック
            If .Blank < 1 Then GoTo LBL_COMPLETED
        Loop Until lngCheckBlank = .Blank
        '--------------------
        ' 解析第二段階
        '--------------------
        Do
            lngCheckBlank = .Blank
            If .Blank < 51 Then
                If AnalysisSecondStage(typCH) Then
                    If CheckCandidateValues(typCH) Then Exit Function ' 候補値チェック
                    If .Blank < 1 Then GoTo LBL_COMPLETED
                End If
            End If
        Loop Until lngCheckBlank = .Blank
        '--------------------
        ' 仮置き
        '--------------------
        Do
            If .ConfirmationFlg Then
                .Blank = .Blank + 1
            Else
                .ConfirmationFlg = True
                Call GetSquareInfoWithTheMinimumCandidateValue(typCH) ' 候補値数最小マスを調査
                If .Number = 0 Then Exit Function                     ' 矛盾があれば関数を抜ける
                Call SetCandidateValuesToArray(typCH)                 ' 候補値数最小マスの候補値を配列に格納
            End If
            If SetTemporary(typCH) Then Exit Function                 ' 仮置き試行　実行できなければ関数を抜ける
        Loop Until AnalysisMainProcessing(typCH)                      ' 再帰　仮置きした値で解析継続
        If pr_blnCompleted Then GoTo LBL_SUCCESS
LBL_COMPLETED:
        pr_lngArray2dData = .Array2dData                              ' 結果を格納
        pr_blnCompleted = True                                        ' 解析終了フラグを起てる
    End With
LBL_SUCCESS:
    AnalysisMainProcessing = True                                     ' 関数正常終了
End Function

' 解析第一段階
Private Sub AnalysisFirstStage(ByRef typH As HierarchyInformation)
    Dim i As Long, j As Long
    With typH
        For i = 1 To 9
            For j = 1 To 9
                If 0 < .Array2dData(i, j) Then  ' 自マスが1～9の場合は自マスの所属する行列、3×3エリアの候補値から、その数値を外す
                    If .CandidateInfo(i, j).RemoveFlg Then Else Call RemoveFromCandidateValues(i, j, .Array2dData(i, j), typH, pr_lngReferenceValue(i), pr_lngReferenceValue(j))
                End If
            Next
        Next
    End With
End Sub

' 候補値チェック
Private Function CheckCandidateValues(ByRef typH As HierarchyInformation) As Boolean
    Dim i As Long, j As Long, r As Long, n As Long
    With typH
        For i = 1 To 9
            For j = 1 To 9
                n = .Array2dData(i, j)
                If 0 = n Then                   ' 数値が決まっていないマスの候補値状況確認
                    r = CountCandidateValue(n, .CandidateInfo(i, j))
                    If r = 1 Then               ' 候補値数が「1」の場合は数値確定
                        .Array2dData(i, j) = n
                        .Blank = .Blank - 1
                        Call RemoveFromCandidateValues(i, j, n, typH, pr_lngReferenceValue(i), pr_lngReferenceValue(j))
                    ElseIf r = 0 Then           ' 候補値数が「0」の場合はエラー
                        CheckCandidateValues = True: Exit Function
                    End If
                Else                            ' 数値が決まっているマスはその数値の候補値を確認
                    If .CandidateInfo(i, j).Flg(n) Then Else CheckCandidateValues = True: Exit Function
                End If
            Next
        Next
    End With
End Function

' 候補値数カウント
Private Function CountCandidateValue(ByRef n As Long, ByRef typCandidateInfo As CandidateInfomation) As Long
    Dim i As Long
    With typCandidateInfo
        For i = 1 To 9
            If .Flg(i) Then CountCandidateValue = CountCandidateValue + 1: n = i
        Next
    End With
End Function

' 解析第二段階
Private Function AnalysisSecondStage(ByRef typH As HierarchyInformation) As Boolean
    Dim i As Long, j As Long
    With typH
        For i = 1 To 9
            For j = 1 To 9
                If .Array2dData(i, j) = 0 Then ' 数値が決まっていない場合は自マスの所属する行列、3×3エリアの候補値状況を確認
                    If CheckCandidateValuesForOtherSquares(i, j, typH) Then AnalysisSecondStage = True
                End If
            Next
        Next
    End With
End Function

' 自マスが所属する行・列・3×3エリアで他マスの候補値確認
Private Function CheckCandidateValuesForOtherSquares(ByVal y As Long, ByVal x As Long, ByRef typH As HierarchyInformation) As Boolean
    Dim i As Long, j As Long, lngRefRow As Long, lngRefColumn As Long, lngCanValue As Long
    lngRefRow = pr_lngReferenceValue(y): lngRefColumn = pr_lngReferenceValue(x)
    With typH
        For lngCanValue = 1 To 9 ' 候補値
            If .CandidateInfo(y, x).Flg(lngCanValue) Then
                For i = 1 To 9
                    If y = i Then Else If .CandidateInfo(i, x).Flg(lngCanValue) Then GoTo LBL_NEXT1
                Next
                GoTo LBL_DECISION
LBL_NEXT1:
                For i = 1 To 9
                    If x = i Then Else If .CandidateInfo(y, i).Flg(lngCanValue) Then GoTo LBL_NEXT2
                Next
                GoTo LBL_DECISION
LBL_NEXT2:
                For i = lngRefRow To lngRefRow + 2
                    For j = lngRefColumn To lngRefColumn + 2
                        If y = i And x = j Then Else If .CandidateInfo(i, j).Flg(lngCanValue) Then GoTo LBL_NEXT3
                    Next
                Next
                GoTo LBL_DECISION
LBL_NEXT3:
            End If
        Next
        Exit Function
LBL_DECISION: ' 自マス以外に存在しない候補値があればその候補値が自マスの数値に決定
        .Array2dData(y, x) = lngCanValue
        .Blank = .Blank - 1
        Call RemoveFromCandidateValues(y, x, lngCanValue, typH, lngRefRow, lngRefColumn)
        CheckCandidateValuesForOtherSquares = True
    End With
End Function

' 自マスが所属する行・列・3×3エリアで指定の数値を候補値から外す
Private Sub RemoveFromCandidateValues(y As Long, x As Long, n As Long, ByRef typH As HierarchyInformation, ReferenceRow As Long, ReferenceColumn As Long)
    Dim i As Long, j As Long
    With typH
        For i = 1 To 9                          ' 自マスの所属する行・列・3×3エリアから指定の候補値フラグをおろす
            .CandidateInfo(i, x).Flg(n) = False
            .CandidateInfo(y, i).Flg(n) = False
        Next
        For i = ReferenceRow To ReferenceRow + 2
            For j = ReferenceColumn To ReferenceColumn + 2
                .CandidateInfo(i, j).Flg(n) = False
            Next
        Next
        Erase .CandidateInfo(y, x).Flg          ' 自マスの候補値フラグを全ておろす
        .CandidateInfo(y, x).Flg(n) = True      ' 指定の数値の候補値フラグをたてる
        .CandidateInfo(y, x).RemoveFlg = True   ' 候補値削除実行フラグをたてる
    End With
End Sub

' 数値が決定していないマスの中で候補値数が最小のマス情報を取得
Private Sub GetSquareInfoWithTheMinimumCandidateValue(ByRef typH As HierarchyInformation)
    Dim i As Long, j As Long, r As Long, n As Long
    With typH
        For i = 1 To 9
            For j = 1 To 9
                If .Array2dData(i, j) = 0 Then
                    r = CountCandidateValue(n, .CandidateInfo(i, j))
                    If .Number = 0 Or r < .Number Then
                        .Number = r: .MinRow = i: .MinColumn = j ' 候補値数、マスの行列を取得
                        If .Number = 2 Or .Number = 9 - (81 - .Blank) Then Exit Sub
                    End If
                End If
            Next
        Next
    End With
End Sub

' 「GetSquareInfoWithTheMinimumCandidateValue」で取得したマスの候補値を配列に格納
Private Sub SetCandidateValuesToArray(ByRef typH As HierarchyInformation)
    Dim i As Long, c As Long
    With typH
        ReDim .MinCandidateValue(1 To .Number)
        For i = 1 To 9
            If .CandidateInfo(.MinRow, .MinColumn).Flg(i) Then
                c = c + 1
                .MinCandidateValue(c) = i
                If c = .Number Then Exit Sub
            End If
        Next
    End With
End Sub

' 数値の仮置き確認と設定
Private Function SetTemporary(ByRef typH As HierarchyInformation) As Boolean
    With typH
        .NumberOfExecutions = .NumberOfExecutions + 1
        If UBound(.MinCandidateValue) < .NumberOfExecutions Then ' 候補数より仮置き回数が増えると実行不可
            SetTemporary = True: Exit Function
        Else                                                     ' 仮置き設定　昇順降順に応じて仮置きする候補値を設定
            If pr_blnAscDesc Then .Array2dData(.MinRow, .MinColumn) = .MinCandidateValue(.NumberOfExecutions) Else .Array2dData(.MinRow, .MinColumn) = .MinCandidateValue(.Number + 1 - .NumberOfExecutions)
        End If
        .Blank = .Blank - 1
    End With
End Function