ナンバーリンク(パズル)を解くVBAに挑戦№2

公開日：2013年5月以前　最終更新日：2017-11-26

ナンバーリンク(パズル)を解くVBAに挑戦№2

ナンバーリンクというパズルをエクセルVBAで解くために作成するプロシージャーになります。

作成するプロシージャー

main

入り口となるメインのプロシードャー

getStart

開始位置を取得するプロシージャー

getEnd

終了位置を取得するプロシージャー

chkEnd

指定位置が終了位置かを判断するプロシージャー

RowColAjust

行・列の数値を指定範囲内に収めつつ、次の位置へ進むためのプロシージャー

getAdvance

進む先を決めるプロシージャー、中核となるプロシージャーです。

dispCell

配列をシートに表示するプロシージャー

とにかく、コードです。


  
    
      Option Explicit


Private SuAry(1 To 10, 1 To 10) As String


Sub main()

　　Dim iR As Integer

　　Dim iC As Integer

　　

　　For iR = 1 To 10

　　　　For iC = 1 To 10

　　　　　　With Cells(iR + 1, iC + 1)

　　　　　　　　If .Value = "" Or Not IsNumeric(.Value) Then

　　　　　　　　　　.Value = ""

　　　　　　　　　　.Font.Size = 9

　　　　　　　　　　.Font.Bold = False

　　　　　　　　　　.NumberFormat = "@"

　　　　　　　　　　SuAry(iR, iC) = ""

　　　　　　　　Else

　　　　　　　　　　SuAry(iR, iC) = .Value

　　　　　　　　End If

　　　　　　End With

　　　　Next

　　Next

　　

　　iR = 1

　　iC = 0

　　Call getStart(iR, iC)

　　Do

　　　　If getAdvance(iR, iC, iR, iC, 0) = "完了" Then

　　　　　　Exit Do

　　　　End If

　　Loop

　　Range("B2:K11").Value = SuAry

End Sub


      Private Function getAdvance(ByVal iR As Integer, ByVal iC As Integer, _

　　　　　　　　　　　　　　ByVal iR2 As Integer, ByVal iC2 As Integer, _

　　　　　　　　　　　　　　ByVal tryCnt As Integer) As String

　　Dim iR3 As Integer

　　Dim iC3 As Integer

　　Dim iR4 As Integer

　　Dim iC4 As Integer

　　Dim i As Integer

　　Dim rtn As String

　　

　　Call getEnd(iR4, iC4, SuAry(iR, iC))

　　Select Case True

　　　　Case iR4 = iR2 - 1 And iC4 = iC2, _

　　　　　　 iR4 = iR2 And iC4 = iC2 + 1, _

　　　　　　 iR4 = iR2 + 1 And iC4 = iC2, _

　　　　　　 iR4 = iR2 And iC4 = iC2 - 1

　　　　　　Call dispCell(True)

　　　　　　tryCnt = 0

　　　　　　If getStart(iR, iC) = False Then

　　　　　　　　getAdvance = "完了"

　　　　　　　　Exit Function

　　　　　　End If

      　　　　　　rtn = getAdvance(iR, iC, iR, iC, tryCnt)

　　　　　　Select Case rtn

　　　　　　　　Case "完了"

　　　　　　　　　　getAdvance = "完了"

　　　　　　　　　　Exit Function

　　　　　　　　Case "終点"

　　　　　　　　　　getAdvance = "終点"

　　　　　　　　　　tryCnt = 0

　　　　　　　　　　If getStart(iR, iC) = False Then

　　　　　　　　　　　　getAdvance = "完了"

　　　　　　　　　　　　Exit Function

　　　　　　　　　　End If

　　　　　　　　Case "破綻"

　　　　　　　　　　getAdvance = "破綻"

　　　　　　　　　　Exit Function

　　　　　　End Select

　　End Select

　　　　

      　　For i = 1 To 4

　　　　Select Case True

　　　　　　Case iR4 > iR2 And iC4 > iC2

　　　　　　　　Select Case i

　　　　　　　　　　Case 1

　　　　　　　　　　　　iR3 = iR2 + 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　　　Case 2

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 + 1

　　　　　　　　　　Case 3

　　　　　　　　　　　　iR3 = iR2 - 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　　　Case 4

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 - 1

　　　　　　　　End Select

　　　　　　Case iR4 > iR2 And iC4 <= iC2

　　　　　　　　Select Case i

　　　　　　　　　　Case 1

　　　　　　　　　　　　iR3 = iR2 + 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　　　Case 2

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 - 1

　　　　　　　　　　Case 3

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 + 1

　　　　　　　　　　Case 4

　　　　　　　　　　　　iR3 = iR2 - 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　End Select

　　　　　　Case iR4 < iR2 And iC4 > iC2

　　　　　　　　Select Case i

　　　　　　　　　　Case 1

　　　　　　　　　　　　iR3 = iR2 - 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　　　Case 2

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 + 1

　　　　　　　　　　Case 3

　　　　　　　　　　　　iR3 = iR2 + 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　　　Case 4

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 - 1

　　　　　　　　End Select

　　　　　　Case iR4 = iR2 And iC4 > iC2

　　　　　　　　Select Case i

　　　　　　　　　　Case 1

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 + 1

　　　　　　　　　　Case 2

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 - 1

　　　　　　　　　　Case 3

　　　　　　　　　　　　iR3 = iR2 - 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　　　Case 4

　　　　　　　　　　　　iR3 = iR2 + 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　End Select

　　　　　　Case iR4 < iR2 And iC4 <= iC2

　　　　　　　　Select Case i

　　　　　　　　　　Case 1

　　　　　　　　　　　　iR3 = iR2 - 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　　　Case 2

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 - 1

　　　　　　　　　　Case 3

　　　　　　　　　　　　iR3 = iR2 + 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　　　Case 4

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 + 1

　　　　　　　　End Select

　　　　　　Case iR4 = iR2 And iC4 <= iC2

　　　　　　　　Select Case i

　　　　　　　　　　Case 1

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 - 1

　　　　　　　　　　Case 2

　　　　　　　　　　　　iR3 = iR2

　　　　　　　　　　　　iC3 = iC2 + 1

　　　　　　　　　　Case 3

　　　　　　　　　　　　iR3 = iR2 - 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　　　Case 4

　　　　　　　　　　　　iR3 = iR2 + 1

　　　　　　　　　　　　iC3 = iC2

　　　　　　　　End Select

　　　　End Select

　　　　

　　　　If iC3 >= 1 And iC3 <= 10 And iR3 >= 1 And iR3 <= 10 Then

　　　　　　If SuAry(iR3, iC3) = "" Then

　　　　　　　　tryCnt = tryCnt + 1

　　　　　　　　Call dispCell(True, iR3, iC3, SuAry(iR, iC) & "-" & tryCnt)

      　　　　　　　　rtn = getAdvance(iR, iC, iR3, iC3, tryCnt)

　　　　　　　　Select Case rtn

　　　　　　　　　　Case "完了"

　　　　　　　　　　　　getAdvance = "完了"

　　　　　　　　　　　　Exit Function

　　　　　　　　End Select

　　　　　　　　If Not IsNumeric(SuAry(iR3, iC3)) Then

　　　　　　　　　　tryCnt = tryCnt - 1

　　　　　　　　　　Call dispCell(True, iR3, iC3, "")

　　　　　　　　End If

　　　　　　End If

　　　　End If

　　Next

　　If IsNumeric(SuAry(iR2, iC2)) Then

　　　　getAdvance = "破綻"

　　Else

　　　　tryCnt = tryCnt - 1

　　　　Call dispCell(True, iR2, iC2, "")

　　　　getAdvance = "別ルート探索"

　　End If

End Function


Private Sub dispCell(ByVal blnDisp As Boolean, _

　　　　　　　　　　 Optional ByVal iR As Integer = 0, Optional ByVal iC As Integer = 0, _

　　　　　　　　　　 Optional ByVal dispStr As String = "")

　　If iR = 1 And iC = 9 And dispStr = "1-1" Then

　　　　DoEvents

　　End If

　　If iR <> 0 And iC <> 0 Then

　　　　SuAry(iR, iC) = dispStr

　　End If

　　If blnDisp = True Then

　　　　Range("B2:K11").Value = SuAry

　　　　DoEvents

　　End If

End Sub


Private Function getStart(ByRef iR As Integer, ByRef iC As Integer) As Boolean

　　iC = iC + 1

　　If RowColAjust(iR, iC) = False Then

　　　　getStart = False

　　　　Exit Function

　　End If

　　

　　Do

　　　　If IsNumeric(SuAry(iR, iC)) Then

　　　　　　If chkEnd(iR, iC) <> True Then

　　　　　　　　getStart = True

　　　　　　　　Exit Function

　　　　　　End If

　　　　End If

　　　　iC = iC + 1

　　　　If RowColAjust(iR, iC) = False Then

　　　　　　getStart = False

　　　　　　Exit Function

　　　　End If

　　Loop

End Function


Private Function RowColAjust(ByRef iR As Integer, ByRef iC As Integer) As Boolean

　　If iC > 10 Then

　　　　iR = iR + 1

　　　　iC = 1

　　End If

　　If iR > 10 Then

　　　　RowColAjust = False

　　　　Exit Function

　　End If

　　RowColAjust = True

End Function


Private Function chkEnd(ByVal iR As Integer, ByVal iC As Integer) As Boolean

　　Dim iR2 As Integer

　　Dim iC2 As Integer


　　Call getEnd(iR2, iC2, SuAry(iR, iC))


　　If iR2 = iR And iC2 = iC Then

　　　　chkEnd = True

　　Else

　　　　chkEnd = False

　　End If

End Function


Private Sub getEnd(ByRef iR2 As Integer, ByRef iC2 As Integer, ByVal i As String)

　　iR2 = 10

　　iC2 = 10

　　Do

　　　　If SuAry(iR2, iC2) = i Then

　　　　　　Exit Sub

　　　　End If

　　　　iC2 = iC2 - 1

　　　　If iC2 < 1 Then

　　　　　　iR2 = iR2 - 1

　　　　　　iC2 = 10

　　　　End If

　　　　If iR2 < 1 Then

　　　　　　Exit Sub

　　　　End If

　　Loop

End Sub

表示は、スタートの数字に"-1","-2"のように連番を下につけて進みます。

行き先が無くなれば、元に戻って別の道を探すといった具合になります。

getAdvance

の中ごろの

For i = 1 To 4
・・・
Next

この部分が、コードの長くなっていて、もう少しすっきり出来そうですが、

こういうとき、中核のロジックは、

多少長くなっても、わかりやすくしておいた方が後々楽だと思います。

この部分こそ、次に右に進むか左に進むか、上か下かを決定する部分になります。

赤字の、

getAdvance

ここが再起呼び出しになります。

・指定数値の階乗を求める再帰VBA ・再帰プロシージャで考慮すべき事項・再帰呼び出しの実践例

パズルのような、無限通りともいえる手順が存在する場合には、再起呼び出しは必須になります。

・指定数値の階乗を求める再帰VBA ・再帰プロシージャで考慮すべき事項・再帰呼び出しの実践例

結局は、ここがかけるかどうかが問題で、再起呼び出しが書けないと、プログラムで解くことは不可能になります。

・指定数値の階乗を求める再帰VBA ・再帰プロシージャで考慮すべき事項・再帰呼び出しの実践例

上記のプログラムは実行してみてもらえれば直ぐにわかりますが、

とても、正解にたどり着けるとは思えません。

バグ云々は別にして、正解にたどり着くのに何時間かかるか、そもそもたどり着けるのか・・・

動きを見れば一目瞭然です。

人間なら絶対に進まない場所に進んでいき、行き場所をなくしたり、

進んだと思ったら、戻ってきてしまったりと、まったく解く気のない動きです(笑)

それで、進む先を自分で見つけて、進めなくなったら、元に戻って別のルートを探すという、

このパズルの本質部分は確実に出来上がりました。

次回以降、無駄な動きを減らして、解にたどり着けるようにしていきます。

№3へ続きます。

ナンバーリンク(パズル)を解くVBAに挑戦： №1 №2 №3 №4 №5 №6 №7 №8

※ナンバーリンクを解くVBAのパフォーマンス改善

「ナンバーリンク(パズル)を解くVBAに挑戦」で作成したVBAでナンバーリンクを解く事には成功しました、しかし、10×10なら数分で解けるものの、10×18でやったところ、4時間半もかかってしまいました。12×12では、待ちきれずに途中で止めてしまいました。

こちらの最終完成版のダウンロード

同じテーマ「マクロVBAサンプル集」の記事

アメブロの記事本文をVBAでバックアップする№1
数独（ナンプレ）を解くVBAに挑戦№1
数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1
ナンバーリンク(パズル)を解くVBAに挑戦№1
ナンバーリンクを解くVBAのパフォーマンス改善№1
オセロを作りながらマクロVBAを学ぼう
 他ブックへのリンクエラーを探し解除
 Excelシートの複雑な計算式を解析するVBA
Excel将棋：マクロVBAの学習用(№1)
Excel囲碁：万波奈穂先生に捧ぐ
 Excel囲碁：再起動後も続けて打てるように改造

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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.日本の祝日一覧｜Excelリファレンス
3.変数宣言のDimとデータ型｜VBA入門
4.FILTER関数（範囲をフィルター処理）｜エクセル入門
5.RangeとCellsの使い方｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
8.マクロとは？VBAとは？VBAでできること｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.メッセージボックス(MsgBox関数)｜VBA入門

ホーム
マクロVBA応用編
マクロVBAサンプル集
ナンバーリンク(パズル)を解くVBAに挑戦№2

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

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。
本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。
This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.

VBAサンプル集
ナンバーリンク(パズル)を解くVBAに挑戦№2