数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№4
数独（ナンプレ）を解くアルゴリズムを例に、アルゴリズムの要点と、それによるパフォーマンスを検証します。
一旦は完結したのですが、見直す機会があり、ほんの少し改善しました。
| Option Explicit Private tryCnt As Long Sub main() Debug.Print Timer Dim SuAry(1 To 9, 1 To 9) As Integer Dim i1 As Integer Dim i2 As Integer tryCnt = 0 Erase SuAry Range("A1:I9").Font.ColorIndex = xlAutomatic For i1 = 1 To 9 For i2 = 1 To 9 If Cells(i1, i2) = "" Then Cells(i1, i2).Font.Color = vbBlue Else SuAry(i1, i2) = Cells(i1, i2) End If Next Next Call trySu(SuAry) Range("A1:I9").Value = SuAry Debug.Print Timer If getBlank(SuAry(), i1, i2) = False Then MsgBox "解読成功" & vbLf & tryCnt Else MsgBox "あれれ・・・" End If End Sub Function trySu(ByRef SuAry() As Integer) As Boolean Dim i1 As Integer Dim i2 As Integer Dim su As Integer Dim tryAry() As Integer If getBlank(SuAry(), i1, i2) = False Then trySu = True Exit Function End If If chkSu(SuAry(), i1, i2, tryAry()) <> 0 Then For su = 1 To 9 If tryAry(su) <> 0 Then SuAry(i1, i2) = su tryCnt = tryCnt + 1 Cells(i1, i2) = su If trySu(SuAry) = True Then trySu = True Exit Function End If End If Next End If SuAry(i1, i2) = 0 Cells(i1, i2) = "" DoEvents trySu = False End Function Function getBlank(ByRef SuAry() As Integer, ByRef i1 As Integer, ByRef i2 As Integer) As Boolean Dim cnt As Integer Dim tryMin As Integer Dim i1Min As Integer Dim i2Min As Integer Dim tryAry() As Integer Dim chkAry1(1 To 9, 1 To 9) As Integer Dim chkAry2(1 To 9, 1 To 9) As Integer tryMin = 10 For i1 = 1 To 9 For i2 = 1 To 9 If SuAry(i1, i2) = 0 Then chkAry1(i1, i2) = chkSu(SuAry, i1, i2, tryAry) End If Next Next Dim ix1 As Integer Dim ix2 As Integer Dim i1S As Integer Dim i2S As Integer For i1 = 1 To 9 For i2 = 1 To 9 If SuAry(i1, i2) = 0 Then cnt = 0 '横を合計 For ix2 = 1 To 9 If ix2 <> i2 Then If chkAry1(i1, ix2) <> 0 Then cnt = cnt + 1 End If Next '縦を合計 For ix1 = 1 To 9 If ix1 <> i1 Then If chkAry1(ix1, i2) <> 0 Then cnt = cnt + 1 End If Next '枠内を合計 i1S = (Int((i1 + 2) / 3) - 1) * 3 + 1 i2S = (Int((i2 + 2) / 3) - 1) * 3 + 1 For ix1 = i1S To i1S + 2 For ix2 = i2S To i2S + 2 If ix1 <> i1 And ix2 <> i2 Then If chkAry1(ix1, ix2) <> 0 Then cnt = cnt + 1 End If Next Next chkAry2(i1, i2) = chkAry1(i1, i2) * 1000 + cnt End If Next Next tryMin = 9999 For i1 = 1 To 9 For i2 = 1 To 9 If SuAry(i1, i2) = 0 Then If tryMin > chkAry2(i1, i2) Then i1Min = i1 i2Min = i2 tryMin = chkAry2(i1, i2) End If End If Next Next If tryMin = 9999 Then getBlank = False Else i1 = i1Min i2 = i2Min getBlank = True End If End Function Function chkSu(ByRef SuAry() As Integer, ByVal i1 As Integer, ByVal i2 As Integer, ByRef tryAry() As Integer) As Integer Dim ix1 As Integer Dim ix2 As Integer Dim i1S As Integer Dim i2S As Integer chkSu = False ReDim tryAry(1 To 9) For ix1 = 1 To 9 tryAry(ix1) = ix1 Next '横をチェック For ix2 = 1 To 9 If ix2 <> i2 Then If SuAry(i1, ix2) <> 0 Then tryAry(SuAry(i1, ix2)) = 0 End If End If Next '縦をチェック For ix1 = 1 To 9 If ix1 <> i1 Then If SuAry(ix1, i2) <> 0 Then tryAry(SuAry(ix1, i2)) = 0 End If End If Next '枠内をチェック i1S = (Int((i1 + 2) / 3) - 1) * 3 + 1 i2S = (Int((i2 + 2) / 3) - 1) * 3 + 1 For ix1 = i1S To i1S + 2 For ix2 = i2S To i2S + 2 If ix1 <> i1 Or ix2 <> i2 Then If SuAry(ix1, ix2) <> 0 Then tryAry(SuAry(ix1, ix2)) = 0 End If End If Next Next chkSu = 0 For ix1 = 1 To 9 If tryAry(ix1) <> 0 Then chkSu = chkSu + 1 End If Next End Function |
赤太字の部分のみの変更です
考え方としては、
候補数値の数が少ないところから攻めるのですが、
候補数値の数が2個くらいがいくつかあるのが普通です。
その時、
3×3のマスの中で、候補数値の数の合計が少ない3×3マス内から攻めた方が良いのではないかという事です。
1つを仮置きした時に、他が自然と決まりやすい3×3マスから攻めるという事です。
上記の計算をして、最終的には青太字の部分で重みを付けて保存し、その下で判定し位置を返しています。
今回の修正前に、既に0.1秒のレベルに達しているので、処理時間の計測はあまり意味がないのですが、
試行回数としては、今回の修正で3割程度は減っているようです、もちろんお題によってになりますが。
さすがに実用的には、これで十分なのではないかと言うレベルになったと思います。
数独を解くアルゴリズムの要点とパフォーマンスの検証 №1 №2 №3 №4
こちらの最終完成版のダウンロード
同じテーマ「マクロVBAサンプル集」の記事
エクセルでファイル一覧を作成
アメブロの記事本文をVBAでバックアップする№1
数独（ナンプレ）を解くVBAに挑戦№1
数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1
ナンバーリンク(パズル)を解くVBAに挑戦№1
ナンバーリンクを解くVBAのパフォーマンス改善№1
オセロを作りながらマクロVBAを学ぼう
他ブックへのリンクエラーを探し解除
新着記事 ・・・新着記事一覧を見る
VBAでファイルを規定のアプリで開く方法｜VBA技術解説（1月20日）
参照設定、CreateObject、オブジェクト式の一覧｜VBA技術解説（1月20日）
ドキュメントプロパティ（BuiltinDocumentProperties,CustomDocumentProperties）｜VBA技術解説（1月19日）
他ブックへのリンクエラーを探し解除｜VBAサンプル集（1月15日）
特殊フォルダの取得（WScript.Shell,SpecialFolders）｜VBA技術解説（1月1日）
数値範囲で表検索するVLOOKUP近似一致｜エクセル関数超技（10月5日）
エクセルVBAでのシート指定方法｜VBA技術解説（9月8日）
VBAのクラスとは（Class,Property,Get,Let,Set）｜VBA技術解説（8月28日）
VBAこれだけは覚えておきたい必須基本例文10｜VBA技術解説（8月22日）
VBAの省略可能な記述について｜ExcelマクロVBA技術解説（8月11日）
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.変数とデータ型（Dim）｜ExcelマクロVBA入門
4.RangeとCellsの使い方｜ExcelマクロVBA入門
5.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
6.マクロって何？VBAって何？｜ExcelマクロVBA入門
7.ひらがな⇔カタカナの変換｜エクセル基本操作
8.定数と型宣言文字（Const）｜ExcelマクロVBA入門
9.繰り返し処理（For Next)｜ExcelマクロVBA入門
10.とにかく書いて見よう（Sub,End Sub）｜VBA入門
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
なお、掲載のVBAコードは自己責任で使ってください。万一データ破損等の損害が発生しても責任は負いません。
