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

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

・一意・複数解判定

・9×9の解答作成

・既存の問題難度向上

'----------------------------------------------------------------------------
' 数独解析モジュール（ビット版） version 4.0.0［作成日］2010.08.30 ［最終更新日］2026.10.09
'----------------------------------------------------------------------------
' ■ 公開関数
'   analyzeSudoku：数独を解析する（構文・引数・戻り値は関数のヘッダーを参照）
'
' ■ 3.0.4 版からの主な変更
'   1) 候補値を Boolean 配列から Long のビット（bit0～bit8 が 1～9）に変更
'   2) 解析第二段階を、行・列・3×3エリア（ユニット）単位のビット演算で実行
'      処理が軽くなったため、空白マス数に関係なく毎回実行する
'   3) マスを 0～80 の1次元の番号で扱い、関係マス・ユニットの表を事前に作成
'
' ■ 使用例　セル[A1:I9]の数値を基に解析を行い、結果をセル[A11:I19]に設定
'
'   Sub ExampleOfUse_analyzeSudoku()
'       Dim wsh        As Worksheet
'       Set wsh = ActiveSheet
'
'       ' 変数にセル[A1:I9]の値を代入
'       Dim varArea    As Variant
'       varArea = wsh.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]に代入
'       wsh.Range("A11:I19").Value = varArea
'   End Sub
'----------------------------------------------------------------------------
Option Explicit

'------------------------------
' 定数
'------------------------------
Private Const ALL_BITS                 As Long = 511    ' 全ての候補値（1～9）のビット
Private Const LAST_CELL                As Long = 80     ' マス番号の最大値（0～80）
Private Const LAST_UNIT                As Long = 26     ' ユニット番号の最大値（行0～8・列9～17・3×3エリア18～26）
Private Const PEER_COUNT               As Long = 20     ' 1マスあたりの関係マス数（同じ行・列・3×3エリアの他マス）
Private Const NO_CELL                  As Long = -1     ' 仮置きするマスがないことを表す番号

'------------------------------
' モジュール変数
'------------------------------
Private pr_lngArray2dData()            As Long          ' 結果格納用
Private pr_blnAscending                As Boolean       ' 仮置きを小さい数値から行うかのフラグ
Private pr_blnTablesCreated            As Boolean       ' 表の作成済みフラグ
Private pr_lngBit(0 To 9)              As Long          ' 数値→ビット（0は0）
Private pr_lngBitCount(0 To 511)       As Long          ' ビット→候補値数
Private pr_lngLowestValue(0 To 511)    As Long          ' ビット→最も小さい候補値（候補値がなければ0）
Private pr_lngPeer(0 To 1619)          As Long          ' 関係マスの表（マス番号×20＋0～19）
Private pr_lngUnitCell(0 To 242)       As Long          ' ユニットのマスの表（ユニット番号×9＋0～8）

'------------------------------
' 構造体
'------------------------------
' 階層情報
Private Type HierarchyInformation
    Values(0 To 80)                    As Long          ' マスの数値（0は空白）
    Candidates(0 To 80)                As Long          ' 候補値のビット（確定済みのマスは0）
    BlankCount                         As Long          ' 空白マス数
    TrialCount                         As Long          ' 仮置き実行回数
    MinCell                            As Long          ' 候補値数最小マスの番号
    MinCandidateCount                  As Long          ' 候補値数最小マスの候補値数
    MinCandidateValues(1 To 9)         As Long          ' 候補値数最小マスの候補値（小さい順）
End Type

'***************************************************************
'* 数独を解析する
'*--------------------------------------------------------------
'* 概要     | 2次元配列に格納された数独の問題を解析し、
'*          | 解析結果を同じ配列に格納する
'* 引数     | 1) pArray2dData  ：数独の問題が格納されている2次元配列
'*          |                    (1 To 9, 1 To 9)
'*          |                    解析結果はこの引数に格納される
'*          | 2) pErrorMessage ：解析でエラーが起きた場合のエラー内容
'*          | 3) pIsAscending  ：候補値を小さい数値から仮置きするか（省略可）
'*          |                    True[既定] / False（大きい数値から）
'* 戻り値   | Long型
'*          | 成功  ：0
'*          | エラー：1 既に全てのマスが埋まっている
'*          |         2 解析不可能な問題
'*          |         3 実行時エラー（解析に失敗）
'*          | 補足  ：エラー内容は引数 pErrorMessage に格納される
'* 作成者   | 坂江
'*--------------------------------------------------------------
'* URL      | https://excel.syogyoumujou.com/freesoft/analysis_sudoku.html
'***************************************************************
Public Function analyzeSudoku(ByRef pArray2dData As Variant, _
                              ByRef pErrorMessage As String, _
                     Optional ByVal pIsAscending As Boolean = True) As Long
On Error GoTo LBL_ERROR
    '------------------------------
    ' 初期化
    '------------------------------
    pr_blnAscending = pIsAscending

    '------------------------------
    ' 事前準備
    '------------------------------
    Dim typHierarchy As HierarchyInformation
    Select Case prepareAnalysis(typHierarchy, pArray2dData)
        Case 1
            pErrorMessage = "既に全てのマスが埋まっています"
            analyzeSudoku = 1
            Exit Function
        Case 2
            pErrorMessage = "この問題は解析不可能です"
            analyzeSudoku = 2
            Exit Function
    End Select

    '------------------------------
    ' 解析
    '------------------------------
    If Not analyzeRecursively(typHierarchy, NO_CELL, 0) Then
        pErrorMessage = "この問題は解析不可能です"
        analyzeSudoku = 2
        Exit Function
    End If

    '------------------------------
    ' 解析結果を格納
    '------------------------------
    pArray2dData = pr_lngArray2dData
    analyzeSudoku = 0
    Exit Function

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    pErrorMessage = "解析に失敗しました"
    analyzeSudoku = 3
End Function

'***************************************************************
'* 解析の事前準備
'*--------------------------------------------------------------
'* 概要     | 表を作成し（初回のみ）、全マスを空白・全候補値の
'*          | 状態にしてから、問題で与えられた数値を確定する
'* 引数     | 1) pHierarchy   ：初期化する階層情報
'*          | 2) pArray2dData ：数独の問題が格納されている2次元配列
'*          |                   (1 To 9, 1 To 9)
'*          |                   1～9以外の値（空白・エラー値など）は
'*          |                   空白マスとして扱う
'* 戻り値   | Long型
'*          | 成功  ：0
'*          | エラー：1 空白マスがない（解析不要）
'*          |         2 与えられた数値に矛盾がある
'***************************************************************
Private Function prepareAnalysis(ByRef pHierarchy As HierarchyInformation, _
                                 ByRef pArray2dData As Variant) As Long
    Dim i As Long, j As Long, k As Long

    '------------------------------
    ' 表を作成（初回のみ）
    '------------------------------
    If Not pr_blnTablesCreated Then Call createTables

    '------------------------------
    ' 問題を読み込み
    '------------------------------
    Dim lngGiven(0 To 80) As Long       ' 与えられた数値（0は空白）
    Dim lngGivenCount     As Long       ' 与えられた数値の個数
    Dim varValue          As Variant
    For i = 1 To 9
        For j = 1 To 9
            varValue = pArray2dData(i, j)
            If IsError(varValue) Then varValue = Empty               ' エラー値はEmptyに変換
            Select Case varValue
                Case 1 To 9                                          ' 数値1～9
                    lngGiven((i - 1) * 9 + (j - 1)) = CLng(varValue)
                    lngGivenCount = lngGivenCount + 1
            End Select
        Next
    Next
    If lngGivenCount = 81 Then                                       ' 空白マスがなければエラー
        prepareAnalysis = 1
        Exit Function
    End If

    '------------------------------
    ' 全マスを空白・全候補値の状態にする
    '------------------------------
    With pHierarchy
        For k = 0 To LAST_CELL
            .Candidates(k) = ALL_BITS
        Next
        .BlankCount = 81
    End With

    '------------------------------
    ' 与えられた数値を確定
    '------------------------------
    For k = 0 To LAST_CELL
        If lngGiven(k) <> 0 Then
            If fixValue(pHierarchy, k, lngGiven(k)) Then             ' 同じ行・列・3×3エリアに同じ数値があれば矛盾
                prepareAnalysis = 2
                Exit Function
            End If
        End If
    Next
    prepareAnalysis = 0
End Function

'***************************************************************
'* 解析で使う表を作成
'*--------------------------------------------------------------
'* 概要     | 数値とビットの対応表、候補値数の表、最も小さい
'*          | 候補値の表、ユニットのマスの表、関係マスの表を
'*          | モジュール変数に作成する
'* 引数     | なし
'* 戻り値   | なし
'***************************************************************
Private Sub createTables()
    Dim i As Long, k As Long, m As Long

    '------------------------------
    ' 数値とビットの対応表
    '------------------------------
    pr_lngBit(0) = 0
    For i = 1 To 9
        pr_lngBit(i) = 2 ^ (i - 1)
    Next

    '------------------------------
    ' 候補値数と最も小さい候補値の表
    '------------------------------
    Dim lngCount  As Long    ' 候補値数
    Dim lngLowest As Long    ' 最も小さい候補値
    For m = 0 To ALL_BITS
        lngCount = 0
        lngLowest = 0
        For i = 9 To 1 Step -1
            If m And pr_lngBit(i) Then lngCount = lngCount + 1: lngLowest = i
        Next
        pr_lngBitCount(m) = lngCount
        pr_lngLowestValue(m) = lngLowest
    Next

    '------------------------------
    ' ユニットのマスの表（行 → 列 → 3×3エリアの順）
    '------------------------------
    Dim lngPos As Long       ' 表の格納位置
    lngPos = 0
    For i = 0 To 8                                                   ' 行
        For k = 0 To 8
            pr_lngUnitCell(lngPos) = i * 9 + k
            lngPos = lngPos + 1
        Next
    Next
    For i = 0 To 8                                                   ' 列
        For k = 0 To 8
            pr_lngUnitCell(lngPos) = k * 9 + i
            lngPos = lngPos + 1
        Next
    Next
    For i = 0 To 8                                                   ' 3×3エリア
        For k = 0 To 8
            pr_lngUnitCell(lngPos) = (((i \ 3) * 3) + (k \ 3)) * 9 + ((i Mod 3) * 3) + (k Mod 3)
            lngPos = lngPos + 1
        Next
    Next

    '------------------------------
    ' 関係マスの表（同じ行・列・3×3エリアの他マス20個）
    '------------------------------
    For k = 0 To LAST_CELL
        lngPos = k * PEER_COUNT
        For m = 0 To LAST_CELL
            If m <> k Then
                If ((m \ 9) = (k \ 9)) Or ((m Mod 9) = (k Mod 9)) Or _
                   (((m \ 27) * 3 + ((m Mod 9) \ 3)) = ((k \ 27) * 3 + ((k Mod 9) \ 3))) Then
                    pr_lngPeer(lngPos) = m
                    lngPos = lngPos + 1
                End If
            End If
        Next
    Next

    pr_blnTablesCreated = True
End Sub

'***************************************************************
'* 解析のメイン処理（再帰関数）
'*--------------------------------------------------------------
'* 概要     | 上の階層の情報を引き継いで仮置きの数値を確定し、
'*          | 解析第一段階・第二段階を行う。解けなければ候補値数
'*          | が最小のマスに仮置きして再帰的に解析する。解けた
'*          | 場合は結果をモジュール変数 pr_lngArray2dData に格納する
'* 引数     | 1) pParent ：上の階層の階層情報
'*          | 2) pCell   ：仮置きするマスの番号
'*          |              最初の呼び出しは NO_CELL
'*          | 3) pValue  ：仮置きする数値
'* 戻り値   | Boolean型
'*          | True ：解析完了
'*          | False：矛盾がある（この階層では解けない）
'***************************************************************
Private Function analyzeRecursively(ByRef pParent As HierarchyInformation, _
                                    ByVal pCell As Long, _
                                    ByVal pValue As Long) As Boolean
    Dim typCurrent   As HierarchyInformation    ' カレント階層の階層情報
    Dim lngPrevBlank As Long                    ' 処理前の空白マス数
    Dim lngValue     As Long                    ' 仮置きする数値

    '------------------------------
    ' 上の階層から引き継ぎ、仮置きした数値を確定
    '------------------------------
    typCurrent = pParent
    If pCell <> NO_CELL Then
        If fixValue(typCurrent, pCell, pValue) Then Exit Function
    End If

    With typCurrent
        Do
            '------------------------------
            ' 解析第一段階：候補値が1つのマスを確定
            '------------------------------
            Do
                lngPrevBlank = .BlankCount
                If fixSingleCandidates(typCurrent) Then Exit Function
                If .BlankCount = 0 Then GoTo LBL_COMPLETED
            Loop Until lngPrevBlank = .BlankCount

            '------------------------------
            ' 解析第二段階：ユニット内で1マスにしかない候補値を確定
            '------------------------------
            lngPrevBlank = .BlankCount
            If fixHiddenSingles(typCurrent) Then Exit Function
            If .BlankCount = 0 Then GoTo LBL_COMPLETED
        Loop Until lngPrevBlank = .BlankCount

        '------------------------------
        ' 候補値数が最小のマスに仮置きして再帰
        '------------------------------
        Call getMinCandidateSquare(typCurrent)
        If .MinCandidateCount = 0 Then Exit Function                ' 空白マスがなければ関数を抜ける（通常は起きない）
        Call setMinCandidateValuesToArray(typCurrent)
        .TrialCount = 0
        Do
            lngValue = getNextTrialValue(typCurrent)
            If lngValue = 0 Then Exit Function                       ' 全ての候補値を試行済み
        Loop Until analyzeRecursively(typCurrent, .MinCell, lngValue)
        GoTo LBL_SUCCESS                                             ' 下の階層で解析完了済み

        '------------------------------
        ' この階層で解析完了
        '------------------------------
LBL_COMPLETED:
        Call setResultToArray(typCurrent)
    End With

LBL_SUCCESS:
    analyzeRecursively = True
End Function

'***************************************************************
'* マスの数値を確定（関係マスの候補値から外す）
'*--------------------------------------------------------------
'* 概要     | 指定のマスに数値を確定し、関係マス（同じ行・列・
'*          | 3×3エリアの他マス）の候補値からその数値を外す
'* 引数     | 1) pHierarchy ：対象の階層情報
'*          | 2) pCell      ：確定するマスの番号（0～80）
'*          | 3) pValue     ：確定する数値（1～9）
'* 戻り値   | Boolean型
'*          | True ：矛盾がある（数値が候補値にない、または
'*          |        候補値がなくなるマスができた）
'*          | False：矛盾がない
'***************************************************************
Private Function fixValue(ByRef pHierarchy As HierarchyInformation, _
                          ByVal pCell As Long, _
                          ByVal pValue As Long) As Boolean
    Dim i As Long
    Dim lngBit  As Long      ' 確定する数値のビット
    Dim lngPeer As Long      ' 関係マスの番号
    lngBit = pr_lngBit(pValue)
    With pHierarchy
        '------------------------------
        ' 自マスの数値を確定
        '------------------------------
        If (.Candidates(pCell) And lngBit) = 0 Then                  ' 候補値にない数値は矛盾
            fixValue = True
            Exit Function
        End If
        .Values(pCell) = pValue
        .Candidates(pCell) = 0
        .BlankCount = .BlankCount - 1

        '------------------------------
        ' 関係マスの候補値から外す
        '------------------------------
        For i = pCell * PEER_COUNT To pCell * PEER_COUNT + PEER_COUNT - 1
            lngPeer = pr_lngPeer(i)
            If .Candidates(lngPeer) And lngBit Then
                .Candidates(lngPeer) = .Candidates(lngPeer) Xor lngBit
                If .Candidates(lngPeer) = 0 Then                     ' 候補値がなくなれば矛盾
                    fixValue = True
                    Exit Function
                End If
            End If
        Next
    End With
End Function

'***************************************************************
'* 候補値が1つのマスの数値を確定（矛盾があれば中断）
'*--------------------------------------------------------------
'* 概要     | 全マスを順に確認し、候補値が1つのマスの数値を
'*          | 確定する（確定済みのマスは候補値が0のため対象外）
'* 引数     | 1) pHierarchy ：対象の階層情報
'* 戻り値   | Boolean型
'*          | True ：矛盾がある
'*          | False：矛盾がない
'***************************************************************
Private Function fixSingleCandidates(ByRef pHierarchy As HierarchyInformation) As Boolean
    Dim k As Long
    Dim lngMask As Long      ' マスの候補値のビット
    With pHierarchy
        For k = 0 To LAST_CELL
            lngMask = .Candidates(k)
            If pr_lngBitCount(lngMask) = 1 Then
                If fixValue(pHierarchy, k, pr_lngLowestValue(lngMask)) Then
                    fixSingleCandidates = True
                    Exit Function
                End If
            End If
        Next
    End With
End Function

'***************************************************************
'* ユニット内で1マスにしかない候補値で数値を確定
'*--------------------------------------------------------------
'* 概要     | 行・列・3×3エリアの27ユニットごとに、1マスにしか
'*          | 現れない候補値をビット演算で求め、そのマスの数値に
'*          | 確定する。確定済みでも候補値でもない数値があるユニット
'*          | は矛盾と判定する
'* 引数     | 1) pHierarchy ：対象の階層情報
'* 戻り値   | Boolean型
'*          | True ：矛盾がある
'*          | False：矛盾がない
'***************************************************************
Private Function fixHiddenSingles(ByRef pHierarchy As HierarchyInformation) As Boolean
    Dim u As Long, i As Long
    Dim lngBase   As Long    ' ユニットの先頭位置（pr_lngUnitCell の添字）
    Dim lngCell   As Long    ' マスの番号
    Dim lngMask   As Long    ' マスの候補値のビット
    Dim lngOnce   As Long    ' 1マス以上に現れる候補値のビット
    Dim lngTwice  As Long    ' 2マス以上に現れる候補値のビット
    Dim lngPlaced As Long    ' 確定済みの数値のビット
    Dim lngHidden As Long    ' 1マスにしか現れない候補値のビット
    Dim lngBit    As Long    ' 処理する候補値のビット
    With pHierarchy
        For u = 0 To LAST_UNIT
            '------------------------------
            ' ユニット内の候補値の出現状況を集計
            '------------------------------
            lngBase = u * 9
            lngOnce = 0
            lngTwice = 0
            lngPlaced = 0
            For i = lngBase To lngBase + 8
                lngCell = pr_lngUnitCell(i)
                lngMask = .Candidates(lngCell)
                lngTwice = lngTwice Or (lngOnce And lngMask)
                lngOnce = lngOnce Or lngMask
                lngPlaced = lngPlaced Or pr_lngBit(.Values(lngCell))
            Next
            If (lngOnce Or lngPlaced) <> ALL_BITS Then               ' 置けない数値があれば矛盾
                fixHiddenSingles = True
                Exit Function
            End If

            '------------------------------
            ' 1マスにしか現れない候補値を確定
            '------------------------------
            lngHidden = lngOnce And Not lngTwice
            Do While lngHidden <> 0
                lngBit = lngHidden And -lngHidden                    ' 最も小さい候補値のビット
                For i = lngBase To lngBase + 8
                    lngCell = pr_lngUnitCell(i)
                    If .Candidates(lngCell) And lngBit Then
                        If fixValue(pHierarchy, lngCell, pr_lngLowestValue(lngBit)) Then
                            fixHiddenSingles = True
                            Exit Function
                        End If
                        Exit For
                    End If
                Next
                lngHidden = lngHidden Xor lngBit
            Loop
        Next
    End With
End Function

'***************************************************************
'* 候補値数が最小のマスを取得
'*--------------------------------------------------------------
'* 概要     | 数値が決まっていないマスの中で候補値数が最小のマスを
'*          | 探し、その番号と候補値数を階層情報に格納する
'* 引数     | 1) pHierarchy ：対象の階層情報
'* 戻り値   | なし
'*          | 補足  ：結果は MinCell / MinCandidateCount に格納
'*          |         （空白マスがなければ MinCandidateCount = 0）
'***************************************************************
Private Sub getMinCandidateSquare(ByRef pHierarchy As HierarchyInformation)
    Dim k As Long
    Dim lngCount As Long     ' 候補値数
    With pHierarchy
        .MinCandidateCount = 0
        For k = 0 To LAST_CELL
            lngCount = pr_lngBitCount(.Candidates(k))
            If lngCount > 0 Then                                     ' 確定済みのマス（候補値0）は対象外
                If .MinCandidateCount = 0 Or lngCount < .MinCandidateCount Then
                    .MinCandidateCount = lngCount: .MinCell = k
                    If lngCount = 2 Or lngCount = 9 - (81 - .BlankCount) Then Exit Sub
                End If
            End If
        Next
    End With
End Sub

'***************************************************************
'* 候補値数が最小のマスの候補値を配列に格納
'*--------------------------------------------------------------
'* 概要     | 「getMinCandidateSquare」で取得したマスの候補値を
'*          | 小さい順に MinCandidateValues に格納する
'* 引数     | 1) pHierarchy ：対象の階層情報
'* 戻り値   | なし
'***************************************************************
Private Sub setMinCandidateValuesToArray(ByRef pHierarchy As HierarchyInformation)
    Dim i As Long, c As Long
    Dim lngMask As Long      ' 候補値数最小マスの候補値のビット
    With pHierarchy
        lngMask = .Candidates(.MinCell)
        For i = 1 To 9
            If lngMask And pr_lngBit(i) Then
                c = c + 1
                .MinCandidateValues(c) = i
                If c = .MinCandidateCount Then Exit Sub
            End If
        Next
    End With
End Sub

'***************************************************************
'* 次に仮置きする数値を取得
'*--------------------------------------------------------------
'* 概要     | 仮置き回数を1つ進め、昇順または降順で次に仮置き
'*          | する候補値を返す
'* 引数     | 1) pHierarchy ：対象の階層情報
'* 戻り値   | Long型
'*          | 成功  ：仮置きする数値（1～9）
'*          | 補足  ：全ての候補値を試行済みの場合は 0
'***************************************************************
Private Function getNextTrialValue(ByRef pHierarchy As HierarchyInformation) As Long
    With pHierarchy
        .TrialCount = .TrialCount + 1
        If .MinCandidateCount < .TrialCount Then Exit Function      ' 候補値数より仮置き回数が多ければ0を返す
        If pr_blnAscending Then
            getNextTrialValue = .MinCandidateValues(.TrialCount)
        Else
            getNextTrialValue = .MinCandidateValues(.MinCandidateCount + 1 - .TrialCount)
        End If
    End With
End Function

'***************************************************************
'* 解析結果を2次元配列に格納
'*--------------------------------------------------------------
'* 概要     | 階層情報のマスの数値を、モジュール変数
'*          | pr_lngArray2dData (1 To 9, 1 To 9) に格納する
'* 引数     | 1) pHierarchy ：解析が完了した階層情報
'* 戻り値   | なし
'***************************************************************
Private Sub setResultToArray(ByRef pHierarchy As HierarchyInformation)
    Dim k As Long
    ReDim pr_lngArray2dData(1 To 9, 1 To 9)
    With pHierarchy
        For k = 0 To LAST_CELL
            pr_lngArray2dData((k \ 9) + 1, (k Mod 9) + 1) = .Values(k)
        Next
    End With
End Sub