数独250問を0.2秒で解析する高速VBAコード
「Excelで数独解析コード -3.0.1-」を図で解説する本を執筆しました。

コードを公開していますが、高速化の追求を最優先にしているため、一般的な書き方と異なる部分が多くあります。
理解の難しい部分はありますが、内容やロジック解説の要望も多くあるため、図を用い詳細を解説することにしました。

この書籍をご覧いただいた方は、特に次の3つの理解を深め、きっとそれらを使いこなせるようになるでしょう。
1.Excelで数独を高速解析するロジック
2.再帰関数による深さ優先探索のアルゴリズム
3.高速化のポイント

また特典として、次のファイルをダウンロードできます。コードと解説も載せています。
・一意・複数解判定ファイル 使用動画
・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