Option Explicit
Sub Saiki_Sudoku()

    Dim Ans(1 To 9, 1 To 9) As String
    Dim Work(1 To 9, 1 To 9) As String
    Dim GoalFlag As Boolean
    Dim I, Ix, ITop As Integer
    Dim J, Jx, JTop As Integer
    Dim LoopFlg As Boolean              '仮定文字が
    Dim Position As Integer             '文字を仮定する場所　( 1 から 81 まで） 再帰関数では呼ばれるとPositionに１を加え、81迄は再帰プログラムを実行
                                        '　82に到達したらそれまでの過程が正しかったのでGoalFlagをTrue 確定にして戻る
    Dim S As String
    
        '問題テーブルから文字を読み込み、それが１文字数字であればその文字を、そうでなければ""をAnsに書き込む。
    For I = 1 To 9
        For J = 1 To 9
            S = Cells(15 + I, 1 + J) '問題のI行、J列を読み込む
            If Len(S) = 1 And InStr("123456789", S) > 0 Then 'Sに読み込んだ値が1字の数字か？
                Ans(I, J) = S ' そうであればAns(I,J)にSを格納
            Else
                Ans(I, J) = "" 'そうでなければ "" を格納
            End If
        Next J
    Next I
    'Ansを解答テーブルに書き込む
    For I = 1 To 9
        For J = 1 To 9
            Cells(4 + I, 1 + J) = Ans(I, J) 'AnsのI行、J列を解答テーブルに書き込む
        Next J
    Next I
    
    Position = 0
    GoalFlag = False
    Call Saiki_Normalize(Position, GoalFlag, Ans)
    If GoalFlag Then
        MsgBox "できました。"
    Else
        MsgBox "問題が正しくないようです。"
    End If
    
 
End Sub


Sub Saiki_Normalize(ByVal Position, GoalFlag, Ans)

    Dim I, Ix, ITop As Integer
    Dim J, Jx, JTop As Integer
    Dim S As String

    If Position >= 81 Then
        GoalFlag = True
        Exit Sub
    End If
    
    Position = Position + 1
    Ix = 1 + (Position - 1) \ 9
    Jx = Position - ((Position - 1) \ 9) * 9
    ITop = BlockTop(Ix)
    JTop = BlockTop(Jx)
    
    If Len(Ans(Ix, Jx)) = 1 Then
        '確定場所なので、次のPositionへ飛ぶ。　戻ってきても何もせず呼び出し元のPositionへ戻る
        Call Saiki_Normalize(Position, GoalFlag, Ans)
        Exit Sub
    End If
 
        'このPositionで取りえる文字をSに収める。
    S = "123456789"
    Ans(Ix, Jx) = ""
    For I = 1 To 9
        S = Replace(S, Ans(Ix, I), "")
        S = Replace(S, Ans(I, Jx), "")
    Next I
    For I = ITop To ITop + 2
        For J = JTop To JTop + 2
            S = Replace(S, Ans(I, J), "")
        Next J
    Next I
    
    Do While Len(S) > 0
        '取りえる文字があるので、その一つを仮にPositionに入れて次のPositionに飛ぶ。
        Ans(Ix, Jx) = Right(S, 1)
        Cells(4 + Ix, 1 + Jx) = Ans(Ix, Jx) 'AnsのIx行、Jx列を解答テーブルに書き込む

        S = Replace(S, Ans(Ix, Jx), "")
        Call Saiki_Normalize(Position, GoalFlag, Ans)
        If GoalFlag Then
            '　確定できたので呼び出し元に戻る
            Exit Sub
        Else
            ' 確定できなかったのでAns(Ix,Jx)を""に戻す
            Ans(Ix, Jx) = ""
            Cells(4 + Ix, 1 + Jx) = "" 'AnsのI行、J列を解答テーブルに書き込む
        End If
    Loop
    
    
    

End Sub


Function BlockTop(IJ) As Integer

    If IJ <= 3 Then
        BlockTop = 1
    ElseIf IJ <= 6 Then
        BlockTop = 4
    Else
        BlockTop = 7
    End If
    
End Function