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 | |
' 行/列/グループ(枠)それぞれの内に数字が存在するかどうかを疑似連想配列で管理 | |
Private RowDictArray(1 To 9, 1 To 9) As Long | |
Private ColumnDictArray(1 To 9, 1 To 9) As Long | |
Private GroupDictArray(1 To 9, 1 To 9) As Long | |
' 行列←→グループ座標変換用 | |
Private PositionToGroupMap(1 To 9, 1 To 9) As Variant | |
Private GroupToPositionMap(1 To 9, 1 To 9) As Variant | |
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 _ | |
RowDictArray(RowNumber, NumberValue) = 0 And _ | |
ColumnDictArray(ColumnNumber, NumberValue) = 0 And _ | |
GroupDictArray(GroupNumber, NumberValue) = 0 _ | |
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 _ | |
RowDictArray(TargetRowNumber, NumberValue) = 0 And _ | |
ColumnDictArray(TargetColumnNumber, NumberValue) = 0 And _ | |
GroupDictArray(GroupNumber, NumberValue) = 0 _ | |
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, OldNumberValue) = 0 | |
ColumnDictArray(ColumnNumber, OldNumberValue) = 0 | |
GroupDictArray(GroupNumber, OldNumberValue) = 0 | |
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) | |
For Index = 1 To 9 | |
For NumberValue = 1 To 9 | |
RowDictArray(Index, NumberValue) = 0 | |
ColumnDictArray(Index, NumberValue) = 0 | |
GroupDictArray(Index, NumberValue) = 0 | |
Next NumberValue | |
Next Index | |
For ColumnNumber = 1 To 9 | |
For RowNumber = 1 To 9 | |
CalcPositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber | |
PositionToGroupMap(RowNumber, ColumnNumber) = Array(GroupNumber, GroupItemNumber) | |
Next RowNumber | |
Next ColumnNumber | |
For GroupNumber = 1 To 9 | |
For GroupItemNumber = 1 To 9 | |
CalcGroupToPosition GroupNumber, GroupItemNumber, RowNumber, ColumnNumber | |
GroupToPositionMap(GroupNumber, GroupItemNumber) = Array(RowNumber, ColumnNumber) | |
Next GroupItemNumber | |
Next GroupNumber | |
For ColumnNumber = 1 To 9 | |
For RowNumber = 1 To 9 | |
NumberValue = NumberMatrix(RowNumber, ColumnNumber) | |
If NumberValue <> 0 Then | |
If RowDictArray(RowNumber, NumberValue) Then | |
ExistRowNumber = RowNumber | |
ExistColumnNumber = RowDictArray(RowNumber, NumberValue) | |
ElseIf ColumnDictArray(ColumnNumber, NumberValue) Then | |
ExistRowNumber = ColumnDictArray(ColumnNumber, NumberValue) | |
ExistColumnNumber = ColumnNumber | |
Else | |
PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber | |
If GroupDictArray(GroupNumber, 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 | |
End Function | |
Sub PositionToGroup(ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByRef GroupNumber As Long, ByRef GroupItemNumber As Long) | |
GroupNumber = PositionToGroupMap(RowNumber, ColumnNumber)(0) | |
GroupItemNumber = PositionToGroupMap(RowNumber, ColumnNumber)(1) | |
End Sub | |
Sub GroupToPosition(ByVal GroupNumber As Long, ByVal GroupItemNumber As Long, ByRef RowNumber As Long, ByRef ColumnNumber As Long) | |
RowNumber = GroupToPositionMap(GroupNumber, GroupItemNumber)(0) | |
ColumnNumber = GroupToPositionMap(GroupNumber, GroupItemNumber)(1) | |
End Sub | |
Sub CalcPositionToGroup(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 CalcGroupToPosition(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を差し替えることで試用可能。