Last active
April 22, 2020 01:43
-
-
Save furyutei/192911043d16f4793c7f21655482aca1 to your computer and use it in GitHub Desktop.
数独をExcelのVBAで解くのをやってみた
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Option Explicit | |
Private Const ScreenUpdate As Boolean = False | |
Private TryCounter As Long | |
' 行/列/グループ(枠)それぞれの内に数字が存在するかどうかを Dictionary で管理 | |
Private RowDictArray(1 To 9) As Object | |
Private ColumnDictArray(1 To 9) As Object | |
Private GroupDictArray(1 To 9) As Object | |
Sub main() | |
Dim NumberMatrix() As Long | |
Dim StartTime As Double | |
Dim EndTime As Double | |
Dim ElapsedTimeString As String | |
TryCounter = 0 | |
If Not InitSudoku(NumberMatrix) Then | |
MsgBox "不正な問題" | |
Exit Sub | |
End If | |
Range("H10").Value = "" | |
Range("C10").Value = "" | |
StartTime = Timer | |
Debug.Print StartTime | |
TrySudoku NumberMatrix | |
EndTime = Timer | |
Debug.Print EndTime | |
Range("A1:I9").Value = NumberMatrix | |
ElapsedTimeString = Format((EndTime - StartTime), "0.00") | |
Debug.Print "連想配列使用版: " & TryCounter & "回試行・" & ElapsedTimeString & "秒経過" | |
Range("C10").Value = TryCounter | |
Range("H10").Value = ElapsedTimeString | |
If CheckNumberMatrix(NumberMatrix) = 0 Then | |
MsgBox "解読成功" & vbLf & TryCounter | |
Else | |
MsgBox "あれれ・・・" | |
End If | |
End Sub | |
Function InitSudoku(ByRef NumberMatrix() As Long) As Boolean | |
Application.ScreenUpdating = False | |
Dim RowNumber As Long | |
Dim ColumnNumber As Long | |
Dim SourceValueArray() As Variant | |
Dim RemainBlankNumber As Long | |
Dim ErrorInfos() As Variant | |
Dim ErrorIndex As Long | |
InitSudoku = True | |
ReDim NumberMatrix(1 To 9, 1 To 9) | |
SourceValueArray = Range("A1:I9").Value | |
For RowNumber = 1 To 9 | |
For ColumnNumber = 1 To 9 | |
If SourceValueArray(RowNumber, ColumnNumber) = 0 Or Cells(RowNumber, ColumnNumber).Font.Color = vbBlue Then | |
Cells(RowNumber, ColumnNumber).Value = "" | |
Cells(RowNumber, ColumnNumber).Font.Color = vbBlue | |
Else | |
NumberMatrix(RowNumber, ColumnNumber) = Cells(RowNumber, ColumnNumber).Value | |
Cells(RowNumber, ColumnNumber).Font.Color = vbBlack | |
End If | |
Next ColumnNumber | |
Next RowNumber | |
RemainBlankNumber = InitNumberMatrix(NumberMatrix, ErrorInfos) | |
If 0 < UBound(ErrorInfos) Then | |
For ErrorIndex = 1 To UBound(ErrorInfos) | |
Cells(ErrorInfos(ErrorIndex)(0), ErrorInfos(ErrorIndex)(1)).Font.Color = vbRed | |
Cells(ErrorInfos(ErrorIndex)(2), ErrorInfos(ErrorIndex)(3)).Font.Color = vbMagenta | |
Next ErrorIndex | |
InitSudoku = False | |
End If | |
Application.CutCopyMode = False | |
Range("A10").Select | |
Application.ScreenUpdating = True | |
End Function | |
Function TrySudoku(ByRef NumberMatrix() As Long) As Boolean | |
Dim RowNumber As Long | |
Dim ColumnNumber As Long | |
Dim Index As Long | |
Dim RemainNumbers() As Long | |
Dim TryNumber As Long | |
If Not GetBlankPosition(NumberMatrix, RowNumber, ColumnNumber, RemainNumbers) Then | |
TrySudoku = True | |
Exit Function | |
End If | |
For Index = 1 To UBound(RemainNumbers) | |
TryNumber = RemainNumbers(Index) | |
UpdateNumberMatrix NumberMatrix, RowNumber, ColumnNumber, TryNumber | |
If ScreenUpdate Then Cells(RowNumber, ColumnNumber) = TryNumber | |
TryCounter = TryCounter + 1 | |
If TrySudoku(NumberMatrix) = True Then | |
TrySudoku = True | |
Exit Function | |
End If | |
Next | |
UpdateNumberMatrix NumberMatrix, RowNumber, ColumnNumber, 0 | |
If ScreenUpdate Then | |
Cells(RowNumber, ColumnNumber) = "" | |
DoEvents | |
End If | |
TrySudoku = False | |
End Function | |
Function CheckNumberMatrix(ByRef NumberMatrix() As Long) As Long | |
Dim ErrorInfos() As Variant | |
Dim ErrorIndex As Long | |
CheckNumberMatrix = InitNumberMatrix(NumberMatrix, ErrorInfos) | |
If UBound(ErrorInfos) <= 0 Then | |
Exit Function | |
End If | |
CheckNumberMatrix = -1 | |
For ErrorIndex = 1 To UBound(ErrorInfos) | |
Cells(ErrorInfos(ErrorIndex)(0), ErrorInfos(ErrorIndex)(1)).Font.Color = vbRed | |
Cells(ErrorInfos(ErrorIndex)(2), ErrorInfos(ErrorIndex)(3)).Font.Color = vbMagenta | |
Next ErrorIndex | |
End Function | |
Function GetBlankPosition(ByRef NumberMatrix() As Long, ByRef TargetRowNumber As Long, ByRef TargetColumnNumber As Long, ByRef RemainNumbers() As Long) As Boolean | |
Dim RemainNumbersMatrix(1 To 9, 1 To 9) As Long | |
Dim RowNumber As Long | |
Dim ColumnNumber As Long | |
Dim GroupNumber As Long | |
Dim GroupItemNumber As Long | |
Dim CheckRowNumber As Long | |
Dim CheckColumnNumber As Long | |
Dim CheckGroupItemNumber As Long | |
Dim NumberValue As Long | |
Dim Point As Long | |
Dim MinPoint As Long | |
Dim RemainNumberCounter As Long | |
Dim NumberIndex As Long | |
TargetRowNumber = 0 | |
TargetColumnNumber = 0 | |
ReDim RemainNumbers(0) | |
GetBlankPosition = False | |
For ColumnNumber = 1 To 9 | |
For RowNumber = 1 To 9 | |
RemainNumberCounter = 0 | |
If NumberMatrix(RowNumber, ColumnNumber) = 0 Then | |
PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber | |
For NumberValue = 1 To 9 | |
If _ | |
Not RowDictArray(RowNumber).Exists(NumberValue) And _ | |
Not ColumnDictArray(ColumnNumber).Exists(NumberValue) And _ | |
Not GroupDictArray(GroupNumber).Exists(NumberValue) _ | |
Then | |
RemainNumberCounter = RemainNumberCounter + 1 | |
End If | |
Next NumberValue | |
End If | |
RemainNumbersMatrix(RowNumber, ColumnNumber) = RemainNumberCounter | |
Next RowNumber | |
Next ColumnNumber | |
MinPoint = 9999 | |
For RowNumber = 1 To 9 | |
For ColumnNumber = 1 To 9 | |
If NumberMatrix(RowNumber, ColumnNumber) = 0 Then | |
Point = 1000 * RemainNumbersMatrix(RowNumber, ColumnNumber) | |
PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber | |
For CheckColumnNumber = 1 To 9 | |
If CheckColumnNumber <> ColumnNumber Then | |
If 0 < RemainNumbersMatrix(RowNumber, CheckColumnNumber) Then Point = Point + 1 | |
'Point = Point + RemainNumbersMatrix(RowNumber, CheckColumnNumber) | |
End If | |
Next | |
For CheckRowNumber = 1 To 9 | |
If CheckRowNumber <> RowNumber Then | |
If 0 < RemainNumbersMatrix(CheckRowNumber, ColumnNumber) Then Point = Point + 1 | |
'Point = Point + RemainNumbersMatrix(CheckRowNumber, ColumnNumber) | |
End If | |
Next | |
For CheckGroupItemNumber = 1 To 9 | |
GroupToPosition GroupNumber, CheckGroupItemNumber, CheckRowNumber, CheckColumnNumber | |
If CheckRowNumber <> RowNumber And CheckColumnNumber <> ColumnNumber Then | |
If 0 < RemainNumbersMatrix(CheckRowNumber, CheckColumnNumber) Then Point = Point + 1 | |
'Point = Point + RemainNumbersMatrix(CheckRowNumber, CheckColumnNumber) | |
End If | |
Next | |
If Point < MinPoint Then | |
TargetRowNumber = RowNumber | |
TargetColumnNumber = ColumnNumber | |
MinPoint = Point | |
End If | |
End If | |
Next ColumnNumber | |
Next RowNumber | |
If MinPoint < 9999 Then | |
PositionToGroup TargetRowNumber, TargetColumnNumber, GroupNumber, GroupItemNumber | |
For NumberValue = 1 To 9 | |
If _ | |
Not RowDictArray(TargetRowNumber).Exists(NumberValue) And _ | |
Not ColumnDictArray(TargetColumnNumber).Exists(NumberValue) And _ | |
Not GroupDictArray(GroupNumber).Exists(NumberValue) _ | |
Then | |
ReDim Preserve RemainNumbers(UBound(RemainNumbers) + 1) | |
RemainNumbers(UBound(RemainNumbers)) = NumberValue | |
End If | |
Next NumberValue | |
GetBlankPosition = True | |
End If | |
End Function | |
Sub UpdateNumberMatrix(ByRef NumberMatrix() As Long, ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByVal NumberValue As Long) | |
Dim GroupNumber As Long | |
Dim GroupItemNumber As Long | |
Dim OldNumberValue As Long | |
PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber | |
OldNumberValue = NumberMatrix(RowNumber, ColumnNumber) | |
If 0 < OldNumberValue Then | |
RowDictArray(RowNumber).Remove OldNumberValue | |
ColumnDictArray(ColumnNumber).Remove OldNumberValue | |
GroupDictArray(GroupNumber).Remove OldNumberValue | |
End If | |
If 0 < NumberValue Then | |
RowDictArray(RowNumber)(NumberValue) = ColumnNumber | |
ColumnDictArray(ColumnNumber)(NumberValue) = RowNumber | |
GroupDictArray(GroupNumber)(NumberValue) = GroupItemNumber | |
End If | |
NumberMatrix(RowNumber, ColumnNumber) = NumberValue | |
End Sub | |
Function InitNumberMatrix(ByRef NumberMatrix() As Long, ByRef ErrorInfos() As Variant) As Long | |
Dim Index As Long | |
Dim RowNumber As Long | |
Dim ColumnNumber As Long | |
Dim GroupNumber As Long | |
Dim GroupItemNumber As Long | |
Dim NumberValue As Long | |
Dim ExistRowNumber As Long | |
Dim ExistColumnNumber As Long | |
InitNumberMatrix = 9 * 9 | |
ReDim ErrorInfos(0) | |
On Error GoTo INIT_DICT | |
For Index = 1 To 9 | |
RowDictArray(Index).RemoveAll | |
ColumnDictArray(Index).RemoveAll | |
GroupDictArray(Index).RemoveAll | |
RowDictArray(Index)(0) = False | |
ColumnDictArray(Index)(0) = False | |
GroupDictArray(Index)(0) = False | |
Next Index | |
For ColumnNumber = 1 To 9 | |
For RowNumber = 1 To 9 | |
NumberValue = NumberMatrix(RowNumber, ColumnNumber) | |
If NumberValue <> 0 Then | |
If RowDictArray(RowNumber).Exists(NumberValue) Then | |
ExistRowNumber = RowNumber | |
ExistColumnNumber = RowDictArray(RowNumber)(NumberValue) | |
ElseIf ColumnDictArray(ColumnNumber).Exists(NumberValue) Then | |
ExistRowNumber = ColumnDictArray(ColumnNumber)(NumberValue) | |
ExistColumnNumber = ColumnNumber | |
Else | |
PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber | |
If GroupDictArray(GroupNumber).Exists(NumberValue) Then | |
GroupToPosition GroupNumber, GroupDictArray(GroupNumber)(NumberValue), ExistRowNumber, ExistColumnNumber | |
Else | |
ExistRowNumber = 0 | |
ExistColumnNumber = 0 | |
RowDictArray(RowNumber)(NumberValue) = ColumnNumber | |
ColumnDictArray(ColumnNumber)(NumberValue) = RowNumber | |
GroupDictArray(GroupNumber)(NumberValue) = GroupItemNumber | |
InitNumberMatrix = InitNumberMatrix - 1 | |
End If | |
End If | |
If 0 < ExistRowNumber Then | |
ReDim Preserve ErrorInfos(UBound(ErrorInfos) + 1) | |
ErrorInfos(UBound(ErrorInfos)) = Array(RowNumber, ColumnNumber, ExistRowNumber, ExistColumnNumber, NumberValue) | |
End If | |
End If | |
Next RowNumber | |
Next ColumnNumber | |
Exit Function | |
INIT_DICT: | |
' CreateObject("Scripting.Dictionary")呼び出しは時間がかかる(=ボトルネック) | |
' →初回(Dictionaryへのアクセスエラー発生時)だけ実施 | |
For Index = 1 To 9 | |
Set RowDictArray(Index) = CreateObject("Scripting.Dictionary") | |
Set ColumnDictArray(Index) = CreateObject("Scripting.Dictionary") | |
Set GroupDictArray(Index) = CreateObject("Scripting.Dictionary") | |
Next Index | |
Index = 1 ' Forループを抜けてここに来ているため、ループカウンタを戻しておかないとインデックスエラーが発生してしまう | |
On Error GoTo 0 | |
Resume | |
End Function | |
Sub PositionToGroup(ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByRef GroupNumber As Long, ByRef GroupItemNumber As Long) | |
GroupNumber = Int((RowNumber + 2) / 3) + 3 * (Int((ColumnNumber + 2) / 3) - 1) | |
GroupItemNumber = 1 + ((RowNumber + 2) Mod 3) + 3 * ((ColumnNumber + 2) Mod 3) | |
End Sub | |
Sub GroupToPosition(ByVal GroupNumber As Long, ByVal GroupItemNumber As Long, ByRef RowNumber As Long, ByRef ColumnNumber As Long) | |
RowNumber = 1 + 3 * ((GroupNumber - 1) Mod 3) + ((GroupItemNumber - 1) Mod 3) | |
ColumnNumber = 1 + 3 * Int((GroupNumber - 1) / 3) + Int((GroupItemNumber - 1) / 3) | |
End Sub |
そのままだと面白くないので、
- 行/列/グループ(枠)それぞれの内に数字が存在するかどうかを連想配列で管理
- ↑の状態は初期化時に全セルをチェックし、その後は変化したセルに対してのみ書き換え
するようにしてみた。
とりあえず素直に、CreateObject("Scripting.Dictionary") を使ってみる……
すると……元のコードと比べ、パフォーマンスが大幅に落ちてしまった(苦笑)。
※セルの更新を表示しないようにした状態で、4~5倍程度時間がかかってしまう。
直感で、行列←→グループ(枠)の座標変換関数がボトルネックになっている気がしたので、計算を省いてショートカットするようにしてみた。
当たりだったっぽい。
総合的に、元のコードよりも約1割前後の速度向上が見られる模様。
なお、現時点ではコアとなるアルゴリズムは変更していないため、試行回数と結果は元のコードと同じになる(空きセル選択方法を微妙に調整していた名残もあるが……)。
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
きっかけ
はけた氏のツイート経由で、
を見て、面白そうだったので、自分なりに書き下してみた。
からダウンロードできる数独のエクセルファイル中のVBAを差し替えることで試用可能。