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

この関数を利用している処理の例です。

・一意・複数解判定

・9×9の解答作成

・既存の問題難度向上

'■数独を解析し結果を表示する関数
 
'【構文】  Sudoku_Kaiseki(ByRef varRangeS As Variant, s As String, Optional AscDesc As Boolean = True) As Long
'
'【戻り値】Long型。解析の成功は「0」、それ以外はなんらかのエラー。エラー番号に対応する定数でエラー内容を表示
'【引数】  varRangeS   解析するセル範囲を指定。解析結果はこの引数 varRangeS に格納される。
'          s           解析時にエラー起きた場合、エラー内容がこの引数 s に格納される。
'          AscDesc　   仮定法を使用し解析する場合、候補値を昇順・降順のどちらから仮定するかを設定
'                      小さい数字から設定する場合は「True」。省略した場合はTrue。

'【使用例】・・・セル範囲[A1:I9]の数字を基に解析を行い、結果をセル範囲[A11:I19]に表示
'Sub Sample()
'   Dim v as Variant, s as String
'   v = Range("A1:I9").Value
'   If Sudoku_Kaiseki(v , s , False) <> 0 Then
'       MsgBox s, vbExclamation + vbOKOnly: Exit Sub
'   End If
'   Range("A11:I19").Value = v
'End Sub

Option Explicit

Private lngResult() As Long                 '結果格納用
Private lngGetRC(1 To 9) As Long            '3×3エリアの基準行/列格納用
Private lngRow As Long, lngCol As Long      '3×3エリアの行/列格納用
Private bolAD As Boolean, bolFin As Boolean '仮定法昇順降順フラグ、解析終了フラグ

Private Const ERR_1 As Long = 1, ERR_2 As Long = 2, ERR_3 As Long = 3
Private Const ERR1 As String = "既に全てのマスが埋まっています。"
Private Const ERR2 As String = "この問題は解析不可能です。"
Private Const ERR3 As String = "解析に失敗しました。"

Type KNUM
    Flg(1 To 9) As Boolean                  '候補数値フラグ
    CkFlg As Boolean                        '「Check_Step1」実行確認フラグ
End Type

Type Separation
    RangeS() As Long                        '解析メイン。ヒント及び解析過程・結果を格納
    KNumF() As KNUM
    KFlg As Boolean                         '「Get_MinValInf」実行確認フラグ
    Blank As Long                           '空白マス数
    Count As Long                           '仮定法実行回数
    MinY As Long                            '候補値数最小マスの行格納
    MinX As Long                            '候補値数最小マスの列格納
    MinN() As Long                          '候補値数最小マスの候補値格納
    Length As Long                          '候補値数最小マス候補値数
End Type

Public Function Sudoku_Kaiseki(ByRef varRangeS As Variant, s As String, Optional AscDesc As Boolean = True) As Long
    Dim typSep As Separation, varError
    On Error GoTo FIN
        bolFin = False
        bolAD = AscDesc
        If Eqipment_K(typSep, varRangeS) Then Sudoku_Kaiseki = ERR_1: GoTo FIN
        If Analysis_Main(typSep) Then Else Sudoku_Kaiseki = ERR_2: GoTo FIN
    On Error GoTo 0
    varRangeS = lngResult
Exit Function
FIN:
    varError = Array(ERR3, ERR1, ERR2)
    s = varError(Sudoku_Kaiseki)
    If Sudoku_Kaiseki = 0 Then Sudoku_Kaiseki = ERR_3
End Function

Private Function Eqipment_K(ByRef typS As Separation, varRangeS As Variant) As Boolean
    Dim i As Long, j As Long, v As Variant, KNumS As KNUM
    For i = 1 To 9
        KNumS.Flg(i) = True
        lngGetRC(i) = ((i - 1) \ 3) * 3 + 1 '(1 to 9)=1,1,1,4,4,4,7,7,7
    Next
    With typS
        ReDim .RangeS(1 To 9, 1 To 9), .KNumF(1 To 9, 1 To 9)
        For i = 1 To 9
            For j = 1 To 9
                v = varRangeS(i, j)
                Select Case v
                    Case 1 To 9             '数値の1～9
                        .RangeS(i, j) = CLng(v)
                        .KNumF(i, j).Flg(CLng(v)) = True
                    Case Else
                        .KNumF(i, j) = KNumS
                        .Blank = .Blank + 1 '空白数カウント
                End Select
            Next
        Next
        Eqipment_K = CBool(.Blank = 0)      '空白がなければエラー
    End With
End Function

Private Function Analysis_Main(ByRef typS As Separation) As Boolean '解析メイン関数。再帰型
    Dim lngKCheck As Long, lngKCheck2 As Long, typSF As Separation
    With typSF                                  'typSから、必要な値を引き継ぎ
        .KNumF = typS.KNumF                     '候補値情報
        .RangeS = typS.RangeS                   'ヒント・解析状況
        .Blank = typS.Blank                     '空白数
        Do
            lngKCheck = .Blank
            If Check_Step1(typSF) Then Exit Function '解析ステップ1
            If lngKCheck = .Blank Then
                Do
                    lngKCheck2 = .Blank
                    If .Blank < 51 Then Call Check_Step2(typSF) '解析ステップ2
                Loop Until lngKCheck2 = .Blank
                If lngKCheck = .Blank Then
                    Do
                        If .KFlg Then
                            .Blank = .Blank + 1
                        Else
                            .KFlg = True
                            Call Get_MinValInf(typSF) '候補値数最小マスを調査
                            If .Length = 0 Then Exit Function '矛盾があれば関数を抜ける
                            Call Set_MinNumber(typSF) '候補値最小マス情報を各変数に格納
                        End If
                        If Check_Katei(typSF) Then Exit Function '仮定法試行。実行できなければ関数を抜ける
                    Loop Until Analysis_Main(typSF)   '再帰。仮定した値での解析実行
                    If bolFin Then GoTo FIN
                End If
            End If
        Loop Until .Blank < 1                   '空白マスがなくなるとループを抜ける
        lngResult = .RangeS                     '結果を格納
        bolFin = True                           '解析終了フラグOn
    End With
FIN:
    Analysis_Main = True                        '関数が正常に終了したことを示すフラグ
End Function

Private Function Check_Step1(ByRef typS As Separation) As Boolean '解析ステップ1
    Dim i As Long, j As Long, r As Long, n As Long, f As Boolean
    With typS
        For i = 1 To 9
            For j = 1 To 9
                If 0 < .RangeS(i, j) Then
                    If Not .KNumF(i, j).CkFlg Then
                        If .KNumF(i, j).Flg(.RangeS(i, j)) Then .KNumF(i, j).CkFlg = True Else Check_Step1 = True: Exit Function
                        lngRow = lngGetRC(i): lngCol = lngGetRC(j)
                        Call Determination(i, j, .RangeS(i, j), typS)
                        f = True
                    End If
                End If
            Next
        Next
        If f Then Else Exit Function
        For i = 1 To 9                      '候補値状況確認
            For j = 1 To 9
                If 0 = .RangeS(i, j) Then
                    r = Check_FgCt(i, j, n, typS)
                    If r = 1 Then           '候補値数が「1」の場合は、数値確定
                        .RangeS(i, j) = n
                        .Blank = .Blank - 1
                        .KNumF(i, j).CkFlg = True
                        lngRow = lngGetRC(i): lngCol = lngGetRC(j)
                        Call Determination(i, j, .RangeS(i, j), typS)
                    ElseIf r = 0 Then       '候補値数が「0」の場合は、矛盾在り
                        Check_Step1 = True: Exit Function
                    End If
                End If
            Next
        Next
    End With
End Function

Private Function Check_FgCt(y As Long, x As Long, n As Long, ByRef typS As Separation) As Long
    Dim i As Long
    With typS.KNumF(y, x)
        For i = 1 To 9
            If .Flg(i) Then Check_FgCt = Check_FgCt + 1: n = i
        Next
    End With
End Function

Private Sub Check_Step2(ByRef typS As Separation) '解析ステップ2
    Dim i As Long, j As Long
    With typS
        For i = 1 To 9
            For j = 1 To 9
                If .RangeS(i, j) = 0 Then Call Check_Other_Areas(i, j, typS)
            Next
        Next
    End With
End Sub

Private Sub Check_Other_Areas(ByVal y As Long, ByVal x As Long, ByRef typS As Separation)
    Dim i As Long, j As Long, k As Long '所属する行・列・3×3エリアの自マス以外のマスの候補値チェック
    lngRow = lngGetRC(y): lngCol = lngGetRC(x)               '自マス以外に候補値がなければ数値決定
    With typS
        For i = 1 To 9
            If .KNumF(y, x).Flg(i) Then
                For j = 1 To 9
                    If y = j Then Else If .KNumF(j, x).Flg(i) Then GoTo NEXT1
                Next
                GoTo DEC
NEXT1:
                For j = 1 To 9
                    If x = j Then Else If .KNumF(y, j).Flg(i) Then GoTo NEXT2
                Next
                GoTo DEC
NEXT2:
                For j = lngRow To lngRow + 2
                    For k = lngCol To lngCol + 2
                        If y = j And x = k Then Else If .KNumF(j, k).Flg(i) Then GoTo NEXT3
                    Next
                Next
                GoTo DEC
NEXT3:
            End If
        Next
    End With
Exit Sub
DEC:
    With typS
        .RangeS(y, x) = i
        .Blank = .Blank - 1
        Call Determination(y, x, i, typS)
    End With
End Sub

Private Sub Determination(y As Long, x As Long, n As Long, ByRef typS As Separation)
    Dim i As Long, j As Long    '自マスの所属する行・列・3×3エリアから、任意の候補フラグを下げる
    With typS                   '自マスの候補値フラグを全て下げ、任意のフラグのみ立てる
        For i = 1 To 9
            .KNumF(i, x).Flg(n) = False
            .KNumF(y, i).Flg(n) = False
        Next
        For i = lngRow To lngRow + 2
            For j = lngCol To lngCol + 2
                .KNumF(i, j).Flg(n) = False
            Next
        Next
        Erase .KNumF(y, x).Flg
        .KNumF(y, x).Flg(n) = True
    End With
End Sub

Private Sub Get_MinValInf(ByRef typS As Separation) '数値が決定していないマスで、候補値が少ないマスを探す
    Dim i As Long, j As Long, r As Long, n As Long '候補値数、マスの行列を取得
    With typS
        For i = 1 To 9
            For j = 1 To 9
                If .RangeS(i, j) = 0 Then
                    r = Check_FgCt(i, j, n, typS)
                    If 0 < r And (.Length = 0 Or r < .Length) Then
                        .Length = r: .MinY = i: .MinX = j
                        If .Length = 2 Or .Length = 9 - (81 - .Blank) Then Exit Sub
                    End If
                End If
            Next
        Next
    End With
End Sub

Private Sub Set_MinNumber(ByRef typS As Separation)
    Dim i As Long, c As Long    '「Get_MinValInf」で取得したマスの候補値を配列に格納
    With typS
        ReDim .MinN(1 To .Length)
        For i = 1 To 9
            If .KNumF(.MinY, .MinX).Flg(i) Then
                c = c + 1
                .MinN(c) = i
                If c = .Length Then Exit Sub
            End If
        Next
    End With
End Sub

Private Function Check_Katei(ByRef typS As Separation) As Boolean '仮定が可能かチェック
    With typS
        .Count = .Count + 1
        If UBound(.MinN) < .Count Then  '候補数より仮定回数が増えると実行不可
            Check_Katei = True: Exit Function
        Else                            '仮定実行。昇順降順に応じて仮定する候補値を取得・設定
            If bolAD Then .RangeS(.MinY, .MinX) = .MinN(.Count) Else .RangeS(.MinY, .MinX) = .MinN(.Length + 1 - .Count)
        End If
        .Blank = .Blank - 1
    End With
End Function