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