数独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