トップ　>　備忘録　>　コード比較　VBA

'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