'VBA用コード

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

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

Option Explicit Option Private Module Private varRangeSudoku As Variant 'Sudoku_Kaisekiの引数 v の、解析するセル範囲の値代入用 Private lngRangeS() As Long 'Variant型変数varRangeSudokuの値をLong型変数に代入する際の格納用 Private bolKNum(1 To 9, 1 To 9, 1 To 9) As Boolean '各マスの可能性のある数値候補絞り込みフラグ 'エラーナンバー Private Const ERR_0 As Long = 0 Private Const ERR_1 As Long = 1 Private Const ERR_2 As Long = 2 Private Const ERR_3 As Long = 3 Private Const ERR_4 As Long = 4 'エラー内容 Private Const ERROR1 As String = "数値以外は入力しないで下さい。" Private Const ERROR2 As String = "既に全てのマスが埋まっています。" Private Const ERROR3 As String = "この問題は解析不可能です。" Private Const ERROR4 As String = "解析に失敗しました。" Private lngKI As Long 'typSep().Count(lngKMinY,lngKMinX)に格納されている、仮定回数代入用 Private lngKP As Long 'typSep().Value(lngKMinY,lngKMinX)に格納されている、12以上の最小値代入用 Private lngKRow As Long '該当マスの3×3エリアで最も左上マスの行を格納 Private lngKCol As Long '該当マスの3×3エリアで最も左上マスの列を格納 Private lngKMin As Long '数値が決定されていないマスの候補数字を連結させたものの中の、最小値を格納 Private lngKMinY As Long 'lngKMinの行座標 Private lngKMinX As Long 'lngKMinの列座標 Private lngKBlank As Long '空白マスカウント用 Private lngExStage As Long 'typSep()のカッコに入る配列番号を格納。以下ステージ番号と表す Private bolKExRe As Boolean 'ステージが戻った際、再度仮定法処理のループプログラムを実行するためのフラグ Private bolContradiction As Boolean '矛盾フラグ。矛盾があった場合に処理を終えるか、仮定をやり直すか、ステージ番号を一つ前に戻すために使用 Private bolConcatenation As Boolean '同盟を有無フラグ Type Separation Value() As Long '各ステージの9×9の値が格納(数値が決定していないマスは、候補数字を連結させたもの) Count(1 To 9, 1 To 9) As Long '該当のマスで仮定した回数記録用 End Type Private typEmpty As Separation 'typSep()初期化用 Private typSep(1 To 52) As Separation
Public Function Sudoku_Kaiseki(ByRef v As Variant, ByRef s As String, Optional SmallLarge As Boolean = True) As Long 'メインモジュール Dim lngKCheck As Long, lngKCheck2 As Long On Error GoTo FIN Call Initialize_K '変数初期化 varRangeSudoku = v '引数 v をvarRangeSudokuに代入 Sudoku_Kaiseki = Eqipment_K() '解析準備 If 0 < Sudoku_Kaiseki Then GoSub FIN If Check_Overlap() Then '初期ヒントのチェック Sudoku_Kaiseki = ERR_3: GoSub FIN End If Do lngKCheck = lngKBlank If lngKBlank < 41 Then Call First_Check_1 Else First_Check_2 '空白マスが少なければ、空白マスをチェック、多ければ、数値マスをチェック If bolContradiction Then GoSub BOLR If lngKCheck = lngKBlank Then Do lngKCheck2 = lngKBlank Call Second_Check '特定の数字を元に空白マスをチェック Loop Until lngKCheck2 = lngKBlank If lngKCheck = lngKBlank Then If Examine() Then GoSub BOLR '全てのマスの候補数値をlngRangeSに格納。候補数値が複数の場合はそれらを連結させる。その後同盟チェック Call Blank_Cells_Count '空白マスを数える。「12」以上の値は「0」に戻す If bolConcatenation Then bolContradiction = Check_Overlap() '確定数字のチェック If bolContradiction Then GoSub BOLR If lngKCheck = lngKBlank Then bolContradiction = Check_bolKNum() BOLR: Do '仮定法ループ処理プログラム If bolContradiction Then '矛盾がある場合 bolContradiction = False If lngExStage < 2 Then Sudoku_Kaiseki = ERR_3: GoSub FIN 'ステージチェック。ステージ1なら解析不能。 If bolKExRe Then bolKExRe = False Else Call Set_Again '前ステージ戻った場合は、Set_Againを行わずKatei_Checkを再実行 Else '矛盾なし。仮定準備 Call Examine(True) 'lngRangeSの数値が確定していないマスに、候補数値を連結し格納 lngExStage = lngExStage + 1 '仮定を実行するため、次のステージに進む typSep(lngExStage).Value = lngRangeS 'lngRangeSの値を新ステージのtypSep().Valueに格納 End If Call Katei_Check(SmallLarge) '仮定法を使用できるかチェック。仮定が規定回数(仮定できる数字の候補数)内なら仮定する。 Loop Until bolKExRe = False ' 仮定が規定回数(仮定できる数字の候補数)を超えたときは前ステージに戻る End If End If End If Loop Until lngKBlank < 1 On Error GoTo 0 v = lngRangeS Exit Function FIN: Select Case Sudoku_Kaiseki Case ERR_0 s = ERROR4: Sudoku_Kaiseki = ERR_4 Case ERR_1 s = ERROR1 Case ERR_2 s = ERROR2 Case ERR_3 s = ERROR3 End Select End Function
Private Sub Initialize_K() Erase typSep Erase bolKNum Erase lngRangeS lngKBlank = 0 lngExStage = 1 bolKExRe = False bolContradiction = False End Sub
Private Function Eqipment_K() As Long '解析準備 Dim i As Long, j As Long, k As Long, v As Variant For Each v In varRangeSudoku '解析範囲に数字以外の値があればエラー If IsNumeric(v) Then Else Eqipment_K = ERR_1: Exit Function Next ReDim lngRangeS(1 To 9, 1 To 9) For i = 1 To 9 For j = 1 To 9 k = CLng(varRangeSudoku(i, j)) 'Variant型varRangeSudokuをLong型lngRangeSに代入(処理速度向上のため) Select Case k Case 1 To 9 lngRangeS(i, j) = k bolKNum(i, j, k) = True '候補数字絞り込みようフラグ。3次元Boolean型変数に値を代入 Case Else For k = 1 To 9 bolKNum(i, j, k) = True Next lngKBlank = lngKBlank + 1 '空白マスのカウント End Select Next Next If lngKBlank = 0 Then Eqipment_K = ERR_2 typSep(1).Value = lngRangeS End Function
Private Function Check_Overlap() As Boolean '数値の重複確認 Dim i As Long, j As Long, k As Long, l As Long, n As Long For i = 1 To 9 For j = 1 To 9 If 0 < lngRangeS(i, j) Then n = lngRangeS(i, j) For k = i + 1 To 9 '行。該当マスの次のマスから If n = lngRangeS(k, j) Then GoSub OVERLAP Next For k = j + 1 To 9 '列。該当マスの次のマスから If n = lngRangeS(i, k) Then GoSub OVERLAP Next If Not (i Mod 3 = 0) Then Call Row_Col_Value(i, j) For k = lngKRow To lngKRow + 2 For l = lngKCol To lngKCol + 2 '行・列で既に調べたマスは省く If i = k Or j = l Then Else If n = lngRangeS(k, l) Then GoSub OVERLAP Next Next End If End If Next Next Exit Function OVERLAP: Check_Overlap = True End Function
Private Sub Row_Col_Value(ByVal y As Long, ByVal x As Long) '引数y,xの所属する3×3エリアの最左上の行・列番号を調べる。 lngKRow = ((y - 1) \ 3) * 3 + 1 lngKCol = ((x - 1) \ 3) * 3 + 1 End Sub
Private Sub First_Check_1() '空白マスが少ない場合のチェック Dim i As Long, j As Long For i = 1 To 9 For j = 1 To 9 If lngRangeS(i, j) = 0 Then '該当マスが空白(0)の場合 Call Tate_Yoko(i, j) '該当マスの行・列を調べ、1~9の数値があった場合、該当マスの候補数値から、その数値を消去 Call Masu(i, j) '該当マスの3×3エリアを調べ、1~9の数値があった場合、該当マスの候補数値から、その数値を消去 If Kakunin(i, j) Then Exit Sub '該当マスの候補数値を調べ、候補数値が1つなら、該当マスにその数値を入れる。0なら矛盾フラグをたてる End If Next Next End Sub
Private Sub First_Check_2() '空白マスが多い場合のチェック Dim i As Long, j As Long For i = 1 To 9 For j = 1 To 9 If 0 < lngRangeS(i, j) Then '該当マスが1~9の場合 If bolKNum(i, j, lngRangeS(i, j)) Then Else bolContradiction = True: Exit Sub '矛盾チェック Call Row_Col_Value(i, j) '該当マスの所属する3×3エリアの最左上の行列番号取得 Call Number_Determination(lngKRow, lngKCol, i, j, lngRangeS(i, j)) '該当マスの行・列、エリアの他マスの候補数値から、該当マスの値を消去 End If Next Next End Sub
Private Sub Second_Check() Dim i As Long, j As Long For i = 1 To 9 For j = 1 To 9 '該当マスの候補数値が行・列・エリアの他のマスにあるかチェック。ない場合はその候補数値が該当マスの値 If lngRangeS(i, j) = 0 Then Call Check_Other_Areas(i, j) Next Next End Sub
Private Sub Tate_Yoko(ByVal y As Long, ByVal x As Long) Dim i As Long '該当マスの行・列を調べ、1~9の数値があった場合、該当マスの候補数値から、その数値を消去 For i = 1 To 9 If lngRangeS(i, x) = 0 Then Else bolKNum(y, x, lngRangeS(i, x)) = False If lngRangeS(y, i) = 0 Then Else bolKNum(y, x, lngRangeS(y, i)) = False Next End Sub
Private Sub Masu(ByVal y As Long, ByVal x As Long) Dim i As Long, j As Long '該当マスの3×3エリアを調べ、1~9の数値があった場合、該当マスの候補数値から、その数値を消去 Call Row_Col_Value(y, x) For i = lngKRow To lngKRow + 2 For j = lngKCol To lngKCol + 2 If lngRangeS(i, j) = 0 Then Else bolKNum(y, x, lngRangeS(i, j)) = False Next Next End Sub
Private Function Kakunin(ByVal y As Long, ByVal x As Long) As Boolean Dim i As Long, v As Long, c As Long '該当マスの候補数値を調べ、候補数値が1つなら、該当マスにその数値を入れる。0なら矛盾フラグをたてる For i = 1 To 9 If bolKNum(y, x, i) Then c = c + 1: v = i Next If c = 1 Then lngRangeS(y, x) = v lngKBlank = lngKBlank - 1 ElseIf c = 0 Then bolContradiction = True Kakunin = True End If End Function
Private Sub Check_Other_Areas(ByVal y As Long, ByVal x As Long) Dim i As Long, j As Long, k As Long '該当マスの候補数値が行・列・エリアの他のマスにあるか調べる。ない場合はその候補数値が該当マスの値 Call Row_Col_Value(y, x) For i = 1 To 9 If bolKNum(y, x, i) Then Do For j = 1 To 9 If y = j Then Else If bolKNum(j, x, i) Then Exit Do Next GoSub DEC Loop Do For j = 1 To 9 If x = j Then Else If bolKNum(y, j, i) Then Exit Do Next GoSub DEC Loop Do For j = lngKRow To lngKRow + 2 For k = lngKCol To lngKCol + 2 If y = j And x = k Then Else If bolKNum(j, k, i) Then Exit Do Next Next GoSub DEC Loop End If Next Exit Sub DEC: lngRangeS(y, x) = i Call Number_Determination(lngKRow, lngKCol, y, x, i) lngKBlank = lngKBlank - 1 End Sub
Private Sub Number_Determination(ByVal LR As Long, ByVal LC As Long, ByVal LY As Long, ByVal LX As Long, ByVal LV As Long) Dim i As Long, j As Long '該当マスの行・列、及び3×3エリアの他マスの候補数値から、該当マスの値を消去 For i = 1 To 9 bolKNum(LY, LX, i) = False bolKNum(i, LX, LV) = False bolKNum(LY, i, LV) = False Next For i = LR To LR + 2 For j = LC To LC + 2 bolKNum(i, j, LV) = False Next Next bolKNum(LY, LX, LV) = True End Sub
Private Function Examine(Optional f As Boolean) As Boolean Dim i As Long, j As Long '全てのマスの候補数値をlngRangeSに格納。候補数値が複数の場合はそれらを連結させる。その後同盟チェック lngKMin = 0 For i = 1 To 9 For j = 1 To 9 If lngRangeS(i, j) = 0 Then '該当マスが空白の場合、候補数値を連結させた数値を該当マスに入れる If Concatenation(i, j) Then Examine = True: Exit Function End If Next Next If f Then Exit Function Else bolConcatenation = False For i = 1 To 9 For j = 1 To 9 Call Check_Alliance(i, j) '同盟のチェック Next Next End Function
Private Function Concatenation(ByVal y As Long, ByVal x As Long) As Boolean '候補数値を調べ、それらを連結し該当マスに入れる Dim r As Long r = Join_Main(y, x) '候補数値を連結させる関数 If r = 0 Then '候補数値がなければ矛盾フラグをたてる bolContradiction = True Concatenation = True Exit Function End If lngRangeS(y, x) = r Call MinY_MinX(y, x, r) '連結した候補数値(二桁以上)の中で最も小さな値と、その行・列を格納 End Function
Private Sub MinY_MinX(ByVal y As Long, ByVal x As Long, ByVal TNum As Long) '連結した候補数値(二桁以上)の中で最も小さな値と、その行・列を格納 If 9 < TNum Then Else Exit Sub If lngKMin = 0 Or TNum < lngKMin Then lngKMin = TNum: lngKMinY = y: lngKMinX = x End If End Sub
Private Sub Check_Alliance(ByVal y As Long, ByVal x As Long) '同盟を探し、見つかった場合は行・列・エリアから同盟の値を削除 Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long, o As Long, p As Long, q As Long, r As Long, v As Long Dim lngLen As Long, lngSV As Long, lngValue As Long If lngRangeS(y, x) < 10 Then Exit Sub '同盟は、候補数値を連結させた二桁以上の数値が対象のため、9以下の場合はこのルーチンを抜ける v = lngRangeS(y, x) lngLen = Len(CStr(v)) '該当マスの値の桁数を調べる If 5 < lngLen Then Exit Sub For i = 1 To 9 If v = lngRangeS(i, x) Then m = m + 1 '該当マスの列を調べ、該当マスと同じ数値の個数をカウントする If lngRangeS(i, x) < 10 Then n = n + 1 '該当マスの列を調べ、1~9のマスをカウントする If v = lngRangeS(y, i) Then o = o + 1 '該当マスの行を調べ、該当マスと同じ数値の個数をカウントする If lngRangeS(y, i) < 10 Then p = p + 1 '該当マスの行を調べ、1~9のマスをカウントする Next If m = lngLen And Not (lngLen = 9 - n) Then '該当マスと同じ数値の個数(列)と該当マスの桁数が一致し lngValue = v '該当マスと同じ列の1~9のマスの個数を、9から引いたものと該当マスの桁数が一致しない場合 For i = 1 To lngLen '同盟成立。9から引いたものと一致する場合は、同盟は成立済み lngSV = lngValue Mod 10 For j = 1 To 9 Call Join_Number(j, x, lngSV, v) '他マス(列)で二桁以上の候補数値から、現マスの候補数値を消去し、残った候補数値を連結し格納 Next lngValue = Int(lngValue / 10) Next End If If o = lngLen And Not (lngLen = 9 - p) Then '上記同様(行) lngValue = v For i = 1 To lngLen lngSV = lngValue Mod 10 For j = 1 To 9 Call Join_Number(y, j, lngSV, v) Next lngValue = Int(lngValue / 10) Next End If Call Row_Col_Value(y, x) For i = lngKRow To lngKRow + 2 For j = lngKCol To lngKCol + 2 If v = lngRangeS(i, j) Then q = q + 1 If lngRangeS(i, j) < 10 Then r = r + 1 Next Next If q = lngLen And Not (lngLen = 9 - r) Then '上記同様(エリア) lngValue = v For i = 1 To lngLen lngSV = lngValue Mod 10 For j = lngKRow To lngKRow + 2 For k = lngKCol To lngKCol + 2 Call Join_Number(j, k, lngSV, v) Next Next lngValue = Int(lngValue / 10) Next End If End Sub
Private Sub Join_Number(ByVal N1 As Long, ByVal N2 As Long, ByVal N3 As Long, p As Long) If 9 < lngRangeS(N1, N2) Then '引数 p と同じ候補数値を消去し、残った候補数値を連結し格納 If p = lngRangeS(N1, N2) Then Exit Sub If bolKNum(N1, N2, N3) Then bolConcatenation = True '同盟成立フラグ bolKNum(N1, N2, N3) = False lngRangeS(N1, N2) = Join_Main(N1, N2) '残った候補数値を連結・格納 End If End If End Sub
Private Function Join_Main(ByVal y As Long, ByVal x As Long) As Long '該当マスの候補数値を連結させる関数 Dim i As Long '候補数値が「1」「3」「4」の場合は、「134」といった具合に連結させる For i = 1 To 9 If bolKNum(y, x, i) Then If Join_Main = 0 Then Join_Main = i Else Join_Main = Join_Main * 10 + i End If End If Next End Function
Private Function Check_bolKNum() As Boolean 'bolKNumの3次元配列に矛盾がないかをチェック Dim i As Long, j As Long, k As Long, l As Long, m As Long For i = 1 To 9 '3次元の仮想ナンバーフラグ For j = 1 To 9 '1次元 Do For k = 1 To 9 '2次元 If bolKNum(j, k, i) Then Exit Do Next GoSub OUT Loop Do For k = 1 To 9 If bolKNum(k, j, i) Then Exit Do Next GoSub OUT Loop Next For j = 1 To 7 Step 3 For k = 1 To 7 Step 3 Do For l = j To j + 2 For m = k To k + 2 If bolKNum(l, m, i) Then Exit Do Next Next GoSub OUT Loop Next Next Next Exit Function OUT: Check_bolKNum = True End Function
Private Sub Katei_Check(ByVal f As Boolean) '仮定法を使用できるかチェック。仮定が規定回数(仮定できる数字の候補数)内なら仮定する。 With typSep(lngExStage) lngKP = .Value(lngKMinY, lngKMinX) '現ステージの候補数値を連結させた二桁以上の最小値をlngKPに格納 lngKI = .Count(lngKMinY, lngKMinX) + 1 '仮定回数をlngKIに格納 If Len(CStr(lngKP)) < lngKI Then '仮定回数が、候補数値を連結させた桁数より多くなった場合は、前ステージに戻る Call Back_Stage Else '仮定回数が、候補数値を連結させた桁数より少ない場合は、仮定する .Count(lngKMinY, lngKMinX) = lngKI '仮定回数をtypSep().Count(lngKMinY, lngKMinX)に格納。lngKPと同じ座標 Call Run_Katei(f) '仮定実行ルーチン End If End With End Sub
Private Sub Back_Stage() '前ステージ戻るためのルーチン lngExStage = lngExStage - 1 '前ステージ番号に戻す bolContradiction = True '矛盾フラグ bolKExRe = True '仮定処理ループプログラムを再度実行するフラグ Call Set_Again 'lngRangeSとbolKNumに戻したステージの値を再セット typSep(lngExStage + 1) = typEmpty '以前のステージを初期化 End Sub
Private Sub Run_Katei(ByVal f As Boolean) '仮定実行ルーチン。引数 f がTrueなら候補数値の中で小さな数字から仮定、Falseなら逆 Dim i As Long, lngKateiNum As Long If f Then lngKateiNum = CLng(Mid$(CStr(lngKP), lngKI, 1)) '候補数値の小さな数値より取り出し Else lngKateiNum = CLng(Mid$(CStr(lngKP), Len(CStr(lngKP)) - lngKI + 1, 1)) '候補数値の大きな数値より取り出し End If lngRangeS(lngKMinY, lngKMinX) = lngKateiNum '仮定 For i = 1 To 9 bolKNum(lngKMinY, lngKMinX, i) = False Next bolKNum(lngKMinY, lngKMinX, lngKateiNum) = True Call Blank_Cells_Count '二桁以上の数値は空白(0)に戻す End Sub
Private Sub Set_Again() '該当ステージの値と候補数値をlngRangeSとbolKNumに再セットするためのルーチン Dim i As Long, j As Long, k As Long, l As Long, r As Long, lngLen As Long lngKMin = 0 lngKBlank = 0 Erase bolKNum lngRangeS = typSep(lngExStage).Value For i = 1 To 9 For j = 1 To 9 r = lngRangeS(i, j) If r = 0 Then lngKBlank = lngKBlank + 1 ElseIf r < 10 Then bolKNum(i, j, r) = True Else lngKBlank = lngKBlank + 1 Call MinY_MinX(i, j, r) lngLen = Len(CStr(r)) For l = 1 To lngLen k = r Mod 10 bolKNum(i, j, k) = True r = Int(r / 10) Next End If Next Next End Sub
Private Sub Blank_Cells_Count() '二桁以上の数値は空白(0)に戻し、併せて空白マスを数えるルーチン Dim i As Long, j As Long lngKBlank = 0 For i = 1 To 9 For j = 1 To 9 If lngRangeS(i, j) = 0 Then lngKBlank = lngKBlank + 1 ElseIf 9 < lngRangeS(i, j) Then lngKBlank = lngKBlank + 1 lngRangeS(i, j) = 0 End If Next Next End Sub