Excel VBAで数独を解く

ExcelVBAで数独を解いてみた
この動画のマクロはWindows11/Office2013で作成してます。

Option Explicit
#If Win64 Then
    ' Excel が64ビット版の場合の関数定義です。
    Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As LongPtr, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#Else
    ' Excel が32ビット版の場合の関数定義です。
    Private Declare Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#End If

Type SudokuType
    盤面 As String * 81
    flag行(8) As Integer
    flag列(8) As Integer
    flag面(8) As Integer
    残り As Integer
End Type
Type AddrType
    行 As Integer
    列 As Integer
    面 As Integer
End Type

Dim answer As String
Dim org As String
Dim cnt As Long
'盤面を描く左上のセル番号
Const board_top_c = 4
Const board_top_r = 3


Sub Macro()
    Dim Driver As New Selenium.WebDriver
    Dim o_elem, Item, i, Sudoku_txt
    Dim startTime, endTime, processTime

    
    '数独を盤面を描く
    With Range(Cells(board_top_c, board_top_r), Cells(board_top_c + 8, board_top_r + 8))
        .ClearContents
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .BorderAround Weight:=xlThick
    End With
    Range(Cells(board_top_c + 0, board_top_r + 3), Cells(board_top_c + 8, board_top_r + 5)).BorderAround Weight:=xlThick
    Range(Cells(board_top_c + 3, board_top_r + 0), Cells(board_top_c + 5, board_top_r + 8)).BorderAround Weight:=xlThick
  
    '数独データ
    Sudoku_txt = "000000000000000027400608000071000300238506419964100750395027800182060974046819205"  '初級
    'Sudoku_txt = "000000000000000280376400000700001000020000000400300006010028000000005000000000003"  '最高級
    Sudoku_txt = "005300000800000020070010500400005300010070006003200080060500009004000030000009700"  'フィンランド人数学者の世界一難しい数独。
    'Sudoku_txt = ""        '空白の場合ネットから拾う

    If Sudoku_txt = "" Then
        'Sudoku_txtがカラの場合ネットからの情報を使う
        'ここでブラウザを立ち上げるため、SeleniumBasicのインストールが別途必要です。
        'ツール - 参照設定でSeleniumTypeLibをチェックすること。

        'Edgeブラウザを起動
        Driver.Start "Edge"
        Driver.Window.SetPosition 1300, 0
        Driver.Window.SetSize 800, 800
        
        Driver.Get "http://www.sudokugame.org/"
        'インラインフレームに制御を切り替える
        Driver.SwitchToFrame "f1"
        '数独マスのinputをとってくる
        Set o_elem = Driver.FindElementsByCss("table.sd td input")
        For Each Item In o_elem
            If Item.Attribute("value") = "" Then
                Sudoku_txt = Sudoku_txt + "0"                           '空マス
            Else
                Sudoku_txt = Sudoku_txt + Item.Attribute("value")       '数字が入ったマス
            End If
        Next
        org = Sudoku_txt
    Else
        org = ""
    End If

    Dim Sudoku As SudokuType        'Sudoku構造体の宣言
    Call Sudoku_init(Sudoku)        'Sudoku構造体の初期化
    
    '問題データーSudoku_txtからSudoku構造体に値を設定
    For i = 0 To 80
        Call Sudoku_setNum(Sudoku, i, Mid(Sudoku_txt, i + 1, 1))
    Next
    Call showBoard(Sudoku.盤面, 0)  '盤面の描画
    
    MessageBoxTimeoutA 0&, Sudoku_txt, "解答スタート", 1, 65536, 2 * 1000
    'カウンタをリセット
    cnt = 0
    '開始時間取得
    startTime = Timer
    
    '------------------------------------
    ' 数独解答
    Call Sudoku_Try(Sudoku)
    '------------------------------------
    
    '終了時間取得
    endTime = Timer
    '処理時間計算
    processTime = endTime - startTime
    Debug.Print cnt & "手 " & processTime & "秒"
    MessageBoxTimeoutA 0&, cnt & "手 " & processTime & "秒", "解答終わりました", 1, 65536, 5 * 1000

    If org <> "" Then
        'ネットからとってきた問題なのでネットに回答
        MessageBoxTimeoutA 0&, Sudoku_txt, "ホームページに回答", 1, 65536, 2 * 1000
        For i = 1 To 81
            o_elem.Item(i).SendKeys Mid(answer, i, 1)
        Next
        
        '「チェック」ボタンを押す
        Driver.FindElementByCss("#btcheck").Click
        MessageBoxTimeoutA 0&, Sudoku_txt, "ホームページに回答終了", 1, 65536, 3 * 1000
        'ポップアップのOKボタンを押す
        Driver.SwitchToAlert.Accept
        
        'ブラウザを閉じる
        Driver.Quit
        Set Driver = Nothing
    End If
End Sub


Private Function Sudoku_Try(t As SudokuType) As Boolean
    Dim rtn As Boolean
    Sudoku_Try = False
    Do
        Do
            '縦or横orブロックの他の数字から1個絞れるマスを埋める
            rtn = methodA(t)
            Call showBoard(t.盤面, 5)       '盤面の描画
        Loop While rtn
        
        If t.残り > 0 Then
            '1-9の数字を入れてみて、数字が1個に絞られるマスを埋める
            rtn = methodB(t)
            Call showBoard(t.盤面, 3)       '盤面の描画
        End If
    Loop While rtn
    
    '数字が置けなくなった。つまり完成したか手詰まり
    
    If t.残り = 0 Then
        '完成
        answer = t.盤面
        Debug.Print "完成"
        Debug.Print answer
        Call showBoard(t.盤面, 3)       '盤面の描画
        Sudoku_Try = True
        Exit Function
        
    Else
        '手詰まり。別のところに数字を入れて再試行処理へ
        'Debug.Print "手詰まり。別のところに数字を入れて再試行処理へ"
        If backtrack(t) = True Then
            Sudoku_Try = True
            Exit Function
        End If
    End If
End Function
Private Function methodA(t As SudokuType) As Boolean
    '縦or横orブロックの他の数字から1個絞れるマスを埋める
    Dim p, flag, n
    For p = 0 To 80
        If Mid(t.盤面, p + 1, 1) = "0" Then
            Dim Addr As AddrType
            Addr = TranslateAddr(p)
            flag = t.flag行(Addr.行) And t.flag列(Addr.列) And t.flag面(Addr.面)
            If flag <> 0 Then
                '512=2の9乗を割れる、flag=2のべき定数であり、フラグが1個しか立ってない状態
                If 512 Mod flag = 0 Then
                    '立ってるビットが1個だけ。つまり数字が1個に絞られている
                    n = getFirstNum(flag)
                    Debug.Print "methodA 位置p:" & Right(" " + str(p), 2) & "　に数字:" & n & "　を置くことが可能"
                    Call Sudoku_setNum(t, p, n)
                    methodA = True
                End If
            End If
        End If
    Next
    methodA = False
End Function

Private Function methodB(t As SudokuType) As Boolean
    '1-9の数字を入れてみて、数字が1個に絞られるマスを埋める
    Dim n, p, flag
    Dim pflag行(9)
    Dim pflag列(9)
    Dim pflag面(9)
    Dim c行(8)
    Dim c列(8)
    Dim c面(8)
    
    
    '数字(1-9)を置けるかをチェックしていく
    For n = 1 To 9
        For p = 0 To 8
            c行(p) = 0
            c列(p) = 0
            c面(p) = 0
        Next
    
        '全マスに対して数字nが置けるかチェック
        For p = 0 To 80
            If Sudoku_canPlace(t, p, n) Then
                Dim Addr As AddrType
                Addr = TranslateAddr(p)
                c行(Addr.行) = c行(Addr.行) + 1
                pflag行(Addr.行) = p
                c列(Addr.列) = c列(Addr.列) + 1
                pflag列(Addr.列) = p
                c面(Addr.面) = c面(Addr.面) + 1
                pflag面(Addr.面) = p
            End If
        Next

        '置ける数字が1個に絞られるマスに数字を埋めて処理を抜ける
        For p = 0 To 8
            If c行(p) = 1 Then
                'Debug.Print "methodB 位置p:" & Right(" " + str(p), 2) & "　に数字:" & n & "　を置くことが可能"
                Call Sudoku_setNum(t, pflag行(p), n)
                methodB = True
                Exit Function
            End If
        Next
        For p = 0 To 8
            If c列(p) = 1 Then
                'Debug.Print "methodB 位置p:" & Right(" " + str(p), 2) & "　に数字:" & n & "　を置くことが可能"
                Call Sudoku_setNum(t, pflag列(p), n)
                methodB = True
                Exit Function
            End If
        Next
        For p = 0 To 8
            If c面(p) = 1 Then
                'Debug.Print "methodB 位置p:" & Right(" " + str(p), 2) & "　に数字:" & n & "　を置くことが可能"
                Call Sudoku_setNum(t, pflag面(p), n)
                methodB = True
                Exit Function
            End If
        Next
        methodB = False
    Next
End Function
Private Function backtrack(t As SudokuType) As Boolean
    '盤面のデータを保存して別のところに数字を入れて再試行
    Dim backupSpace As SudokuType, p, n
    backtrack = False
    backupSpace = t
    p = Sudoku_nextAvail(t)
    For n = 1 To 9
        If Sudoku_canPlace(t, p, n) Then
            Debug.Print "backtrack 位置p:" & Right(" " + str(p), 2) & "　に数字:" & n & "　を置いて再試行"
            Call Sudoku_setNum(t, p, n)
            If Sudoku_Try(t) = True Then
                backtrack = True
                Exit Function
            End If
            
            t = backupSpace
        End If
    Next
End Function
Sub Sudoku_init(t As SudokuType)
    'SudokuType型データを初期化
    'flagに &H3FE = b0011 1111 1110を設定。
    'つまり123456789の数字のフラグを建てた状態
    Dim i As Integer
    For i = 0 To 8
        t.flag行(i) = &H3FE
        t.flag列(i) = &H3FE
        t.flag面(i) = &H3FE
        t.残り = 81
    Next
End Sub

Sub Sudoku_setNum(t As SudokuType, p, n)
    '数独に数字を置く
    'p:先頭からの位置
    'n:置く数字
    Dim mask As Integer
    Dim Addr As AddrType
    Addr = TranslateAddr(p)
    mask = Not (2 ^ n)
    
    '行列面のflagエリアに置く数字に対応するビットを下ろす
    '              ---- --98 7654 321-
    ' 各flagエリア 0000 0000 0000 0000
    ' 例　2を置く場合、mask=not(2^2)=not(4)=not(b000000100)=b11111011
    ' flag And mask より、flagの3bit目が0になる
    t.flag行(Addr.行) = t.flag行(Addr.行) And mask
    t.flag列(Addr.列) = t.flag列(Addr.列) And mask
    t.flag面(Addr.面) = t.flag面(Addr.面) And mask
    
    ' t.盤面のp番目(pは0始まり)をnにする
    'Debug.Print "p=" & p & "-> " & Right(str(n), 1)
    t.盤面 = Mid(t.盤面, 1, p) & Right(str(n), 1) & Mid(t.盤面, p + 2)  '1文字置き換え

    If n > 0 Then
        t.残り = t.残り - 1
    End If
    'カウントアップ
    cnt = cnt + 1
End Sub
Private Function TranslateAddr(p) As AddrType
    '先頭からの位置p(0-80)から行列面を求める
    Dim bq As Integer, br As Integer, i As Byte
    TranslateAddr.行 = Int(p / 9)      '9で割った商    行を表す
    TranslateAddr.列 = Int(p Mod 9)    '9で割った余り  列を表す
    '行列をさらに3で割って、第何面を求める
    bq = Int(TranslateAddr.列 / 3)
    br = Int(TranslateAddr.行 / 3)
    TranslateAddr.面 = br * 3 + bq
End Function
Private Function getFirstNum(flag) As Integer
    getFirstNum = 0
    If flag = 0 Then
        Exit Function
    End If
    
    '最初に1が立ってるフラグ位置を求める
    'つまり可能性のある最小の数字
    While (flag And 1) = 0
        getFirstNum = getFirstNum + 1
        flag = Int(flag / 2)    'フラグを右にシフト
    Wend
End Function

Private Function Sudoku_nextAvail(t As SudokuType) As Integer
    '数字を置ける次の空マスを見つける
    Dim min_c, min_p, p
    min_c = 10
    min_p = -1
    For p = 0 To 80
        If Mid(t.盤面, p + 1, 1) = "0" Then
            Dim c
            c = Sudoku_countAvail(t, p)
            If c < min_c Then
                min_c = c
                min_p = p
            End If
        End If
    Next
    Sudoku_nextAvail = min_p
End Function

Private Function Sudoku_countAvail(t As SudokuType, p) As Integer
    '行列面のflagのAND演算より、置ける可能性のある数字の個数を求める
    Dim flag
    Dim Addr As AddrType
    Addr = TranslateAddr(p)
    'flag = getFlags(t, p)
    flag = t.flag行(Addr.行) And t.flag列(Addr.列) And t.flag面(Addr.面)
    Sudoku_countAvail = countBits(flag)
End Function
Private Function countBits(f) As Integer
    'fの2進数表記で1が何個あるか
    countBits = 0
    While f
        If f And 1 Then
            countBits = countBits + 1
        End If
        f = Int(f / 2)
    Wend
End Function
Function Sudoku_canPlace(t As SudokuType, p, n)
    'pに数字nが置けるかチェックする
    If Mid(t.盤面, p + 1, 1) <> "0" Then
        'すでに数字が置かれている
        Sudoku_canPlace = 0
    Else
        Dim Addr As AddrType
        Addr = TranslateAddr(p)
        'マスの行列面の状態ビットと数字ビットのAND演算をして、置けるかどうか判定
        'おけない場合Sudoku_canPlaceは0になる。
        Sudoku_canPlace = t.flag行(Addr.行) And t.flag列(Addr.列) And t.flag面(Addr.面) And (2 ^ n)
    End If
End Function

Sub showBoard(Sudoku_txt, f_shoki)
    '盤面をシートに書く
    Dim num, p
    Dim Addr As AddrType
    For p = 0 To 80
        Addr = TranslateAddr(p)
        num = CInt(Mid(Sudoku_txt, p + 1, 1))
        Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.Size = 36
        If num > 0 Then
            Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列) = num
        Else
            Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列) = ""
        
        End If
        'マスの文字色
        If f_shoki = 0 Then
            '初期状態(f_shoki=0)の描画
            '文字色は数字は黒色で、空マスは赤を入れる
            If num > 0 Then
                Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.ColorIndex = 1
            Else
                Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.ColorIndex = 3
            End If
        Else
            '問題の数字以外は文字色にf_shokiを入れる
            If Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.ColorIndex <> 1 Then
                Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.ColorIndex = f_shoki
            End If
        
        End If
    Next
    DoEvents
End Sub