VBAサンプル集
数独(ナンプレ)を解くアルゴリズムの要点とパフォーマンスの検証№4

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
最終更新日:2018-04-04

数独(ナンプレ)を解くアルゴリズムの要点とパフォーマンスの検証№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を学ぼう
他ブックへのリンクエラーを探し解除
Excelシートの複雑な計算式を解析するVBA


新着記事NEW ・・・新着記事一覧を見る

Variantの数値型と文字列型の比較|エクセル雑感(7月1日)
VBAのVariant型について|VBA技術解説(6月30日)
VBAのString型の最大文字数について|エクセル雑感(6月20日)
VBAで表やグラフをPowerPointへ貼り付ける|VBAサンプル集(6月19日)
アクティブシート以外の表示(Window)に関する設定|VBA技術解説(6月17日)
マクロ記録での色のマイナス数値について|エクセル雑感(6月16日)
ツイッター投稿用に文字数と特定文字で区切る|エクセル雑感(6月15日)
日付の謎:IsDateとCDate|エクセル雑感(6月14日)
IFステートメントの判定|エクセル雑感(6月13日)
インクリメンタルサーチの実装|ユーザーフォーム入門(6月12日)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
7.繰り返し処理(For Next)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.マクロはどこに書くの(VBEの起動)|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ