[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『迷路ってvbaで作れるのでしょうか』（羽田空港）
こんなことができるのかわからないのですが、お分かりの方がいらっしゃればぜひ教えてください。
Sheet1のA1を基準にして20列×20行の正方形のマスを作成します。列幅や行の高さについては正方形にして、2桁の数字が入るくらいの大きさのものにしたいです。
Sheet2のA列には1〜30までの数字が入っています。
Sheet1のA1にSheet2の1を入れて、T20をゴールにして、まずはA1からT20まで数字が通し番号で並ぶように迷路の答えのようなものを作成します（1~30を使い切ったら、30→1→2という感じで最初へ戻り、T20が30で終わる必要はありません）。この迷路の答えのようなものはマクロを実行するごとに形が変わります。一度使ったセルを再度使うことはないようにしたいです。
そして迷路の答えになっている以外のセルには数字が適当に配置されたらと考えています。
うまく説明できているかどうかわかりませんが、よろしくお願いいたします。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
ありがとうございます。いろいろと探していたら以下のサイトに辿り着きまた
https://www.worksheetworks.com/english/alphabet/alphabet-maze.html
これがわたしが考えていたものなのですが、ご教示いただいたサイトを見てもわたしにはこれを改造して上記サイトの内容に改造できるだけの知識がありません。諦めた方が良さそうです。
（羽田空港） 2022/10/22(土) 16:35:26
投稿しましたが、見直しますので、いったん取り下げます。 他の方の投稿を参考にしてください。22:26
（γ） 2022/10/25(火) 19:43:17
アクティブセルを基点に指定の数だけセルを移動します。
次進む方向は乱数任せです。
一度通ったセルは再度通ることができません。
袋小路になったらそこでお手上げです。
袋小路にならないで指定数セルを移動出来たら「完了」
です。
完了まで行ったら出来た図が迷路に見えなくもないです・・・。
Sub main
でスタートです。
'Rangeオブジェクト版
Option Explicit
Public mystop As Boolean
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim saidai As Long Dim saishou As Long Dim cnt As Long Dim NRng As Range Dim hantei As Boolean Dim bl As Boolean Dim prerng As Range Dim iti As String
Sub main()
Dim maxnum As Long
mystop = True
Worksheets(1).Cells.Clear
maxnum = 100 '完了の数値指定
saidai = 4
saishou = 1
cnt = 1
ActiveCell.Value = cnt
bl = False
Do Until bl = True
If mystop = False Then Exit Do
bl = False
Call nextrng
cnt = cnt + 1
'**********
If cnt = 2 Then
Set prerng = Worksheets(1).Cells(1, 1)
If NRng.Address = prerng.Offset(1).Address Then
With prerng
'上
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'左
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'右
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
Else
With prerng
'上
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'下
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'左
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End If
Else
iti = prerng.Row - ActiveCell.Row & _
prerng.Column - ActiveCell.Column & ActiveCell.Row - NRng.Row & ActiveCell.Column - NRng.Column
'MsgBox cnt & " " & iti
Select Case iti
Case "-10-10"
Call kei1
Case "-100-1"
Call kei2
Case "-1001"
Call kei3
Case "1010"
Call kei1
Case "100-1"
Call kei4
Case "1001"
Call kei5
Case "0-1-10"
Call kei5
Case "0-110"
Call kei3
Case "0-10-1"
Call kei6
Case "01-10"
Call kei4
Case "0110"
Call kei2
Case "0101"
Call kei6
End Select
End If
If cnt = maxnum Then
If NRng.Address = ActiveCell.Offset(1).Address Then
With NRng
'左
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'右
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'下
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
ElseIf NRng.Address = ActiveCell.Offset(-1).Address Then
With NRng
'左
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'右
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'上
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
ElseIf NRng.Address = ActiveCell.Offset(, 1).Address Then
With NRng
'右
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'上
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'下
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
Else
With NRng
'左
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'上
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'下
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End If
End If
If cnt > 1 Then
Set prerng = ActiveCell
Else
Set prerng = Worksheets(1).Cells(1, 1)
End If
NRng.Select
NRng.Value = cnt
Call hukuro
If hantei = True Then
AppActivate Application.Caption
MsgBox "袋小路！"
bl = True
End If
'Sleep 10
Sleep 1
If cnt = maxnum Then bl = True
Loop
If cnt = maxnum Then MsgBox "完了"
End Sub
Function nextrng()
Dim Myrnd As Long
Dim chk As Boolean
chk = True
Randomize
Myrnd = Int((saidai - saishou + 1) * Rnd + saishou)
Select Case Myrnd
Case 1
If ActiveCell.Row = 65536 Then
chk = False
Else
Set NRng = ActiveCell.Offset(1)
End If
Case 2
If ActiveCell.Row = 1 Then
chk = False
Else
Set NRng = ActiveCell.Offset(-1)
End If
Case 3
If ActiveCell.Column = 256 Then
chk = False
Else
Set NRng = ActiveCell.Offset(, 1)
End If
Case 4
If ActiveCell.Column = 1 Then
chk = False
Else
Set NRng = ActiveCell.Offset(, -1)
End If
End Select
If chk = False Then
Call nextrng
End If
If NRng.Value <> "" Then
Call nextrng
End If
End Function
Function hukuro()
hantei = False
If NRng.Row = 1 Then
If NRng.Column = 1 Then
If NRng.Offset(1).Value <> "" And NRng.Offset(, 1).Value <> "" Then
hantei = True
End If
ElseIf NRng.Column = 256 Then
If NRng.Offset(1).Value <> "" And NRng.Offset(, -1).Value <> "" Then
hantei = True
End If
Else
If NRng.Offset(1).Value <> "" And NRng.Offset(, 1).Value <> "" And NRng.Offset(, -1).Value <> "" Then
hantei = True
End If
End If
ElseIf NRng.Row = 65536 Then
If NRng.Column = 1 Then
If NRng.Offset(-1).Value <> "" And NRng.Offset(, 1).Value <> "" Then
hantei = True
End If
ElseIf NRng.Column = 256 Then
If NRng.Offset(-1).Value <> "" And NRng.Offset(, -1).Value <> "" Then
hantei = True
End If
Else
If NRng.Offset(-1).Value <> "" And NRng.Offset(, 1).Value <> "" And NRng.Offset(, -1).Value <> "" Then
hantei = True
End If
End If
Else
If NRng.Column = 1 Then
If NRng.Offset(, 1).Value <> "" And NRng.Offset(-1).Value <> "" And NRng.Offset(1).Value <> "" Then
hantei = True
End If
ElseIf NRng.Column = 256 Then
If NRng.Offset(, -1).Value <> "" And NRng.Offset(1).Value <> "" And NRng.Offset(-1).Value <> "" Then
hantei = True
End If
Else
If NRng.Offset(, -1).Value <> "" And NRng.Offset(, 1).Value <> "" And NRng.Offset(1).Value <> "" And NRng.Offset(-1).Value <> "" Then
hantei = True
End If
End If
End If
End Function
Function kei1()
With ActiveCell
'左
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'右
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Function
Function kei2()
With ActiveCell
'左
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'下
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Function
Function kei3()
With ActiveCell
'右
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'下
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Function
Function kei4()
With ActiveCell
'左
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'上
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Function
Function kei5()
With ActiveCell
'右
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'上
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Function
Function kei6()
With ActiveCell
'上
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'下
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Function
（MK） 2022/10/25(火) 21:05:45
A1セルが基点じゃなくてもA1セルに罫線が引かれるというバグ がありますね。気にしないで下さい・・・。 （MK） 2022/10/25(火) 21:09:44
こんにちは、 どうなったか気になったので、昨夜...覗いてしまいました。
質問者さんは、昨日の今日で、もう諦めてしまったのでしょうか？ （みみ）さんがピックアップしてくれた中に、良いヒントはありませんでしたか？ 見ても...わからなかったと言うところでしょうか。。 全て理解しようとしたら、相当な時間を要すると思いますよ。
尚、長文の為 ...note（ノート）で、クリエイターが各自のコンテンツを発表 する時のように、目次の作成をしました。 ここから先は、お時間の余裕がある方のみ閲覧ください。
************************************************************ ▼目次 閲覧推定所要時間 : 15分
1. トピ主さんへの質問 2. 範囲を縮小版でチャレンジ ( レイアウトの説明と、画像を添付 ) 3. 実装コードの作成について ( 著作権 ) 4. 実装コードのモジュールへの貼付け方 ( 各プロシージャについて ) 5. 実装コードの添付 ( ちゃんと動くと思われる ) 6. 今後の取り組みについて 7. どうでもいい話
************************************************************
■1. トピ主さんへの質問
質問者さんの、希望のレイアウト...A1 スタート地点から、 T20 ゴール地点( 20列×20行のレイアウトとする )でありますが 残念ながら、すぐにそれを実現するには...時間が足りません。
まずは、確認からです。( 質問者さんが、もう閲覧しに来るかわかりませんが^^; )
下記のURLにあるように、アルファベットで迷路を作成するってことですね？ www.worksheetworks.com ( Alphabet Maze ) https://www.worksheetworks.com/english/alphabet/alphabet-maze.html
＞Sheet2のA列には1〜30までの数字が入っています。 ＞Sheet1のA1にSheet2の1を入れて、T20をゴールにして、まずはA1からT20まで ＞数字が通し番号で並ぶように迷路の答えのようなものを作成します ＞（1~30を使い切ったら、30→1→2という感じで最初へ戻り、T20が30で終わる必要はありません）。
この意図が、既に理解できませんが、Sheet2のA列に、アルファベットのＡからＺ迄が並ぶとして Ａ〜Ｚまで来たら、最初のAに戻るって事はわかります。
だが、Sheet2の必要性がわかりません。 もしかしてですが...迷路のスタートが、必ずしも「 A 」でない場合を はじまりとするような設定を、Sheet2でしたいのでしょうか？ もしくは、A TO Z 順ではなく、Z TO A の逆順序とか？
＞この迷路の答えのようなものはマクロを実行するごとに形が変わります。 はい、そうですね。勿論マクロを利用するのですから、新規迷路を瞬時に 作成できなければ意味がありません。
＞一度使ったセルを再度使うことはないようにしたいです。 なんのこっちゃん？ … 言ってる事が、さっぱりわかりませんw ああ...わかりました。交差がなしってことですね。( 後で、わかりました。)
＞そして迷路の答えになっている以外のセルには数字が適当に配置されたらと考えています。 いやいや、適当ではダメでしょ!! 迷路なんだから、分岐点で正解路と、不正解路（行き止まり）とを アルファベットを両方に走らるようにしないと、簡単すぎてすぐゴールしてしまいますよww
とゴタゴタ言ってたところで、前に進まないので… let's go
■2. 範囲を縮小版でチャレンジ ( レイアウトの説明と、画像を添付 )
下記のレイアウトは、範囲が縮小版ですが…ある程度は、質問者さんの 趣旨に近い処まで実現できたのでご報告します。
|[A]|[B]|[C]|[D]|[E]|[F]|[G]|[H]|[I]|[J]|[K]|[L]
[1] | | ▼
[2] | | A | D | E | F | G | T | U | X | Y | B |
[3] | | B | C | P | Q | H | I | V | W | Z | A |
[4] | | C | J | O | R | S | J | K | Y | Z | A |
[5] | | D | E | N | M | L | K | L | B | V | U |
[6] | | I | F | G | H | W | X | M | N | W | T |
[7] | | H | G | J | I | Z | Y | I | O | X | S |
[8] | | M | L | K | L | A | K | J | P | Q | R |
[9] | | N | Q | R | M | B | C | D | E | F | G |
[10]| | O | P | S | T | U | V | W | X | Y | H |
[11]| | V | U | T | S | R | S | T | U | Z | A |
[12]| | ▼
上記の、アルファベット迷路図は、 ▼B2セルがスタート地点 ▼K11セルがゴール地点です。
Bの次の分岐でCが右と、下に分かれます。 上記の図で見ると、非常にわかり難いので…下記のサイトを使用して 画像を添付させていただきました。
尚、添付画像のレイアウトは、壁の排除をする前の段階です。 黄色の背景色のルートが、正解となります。
私が、「 ファイルなう 」と言うサイトへ… アップロードしたファイルです。 Windowsフォトビューアーで画像だけが閲覧可能です。
Alphabet.Maze.JPG 68 KB ダウンロードURL: https://d.kuku.lu/bfd79e291
「 ファイルなう 」運営者情報 くくさま @kukusama https://twitter.com/kukusama
不正解のルートも、適度に反映された例で こんなに毎回上手く反映されることはありません。
でも、デバックするとわかるのですが、最初の ランダムなルートの迷路を描画するマクロにて ゴールのセルまで運よくアルファベットが走らず、 四方が通路に囲まれて行き止まりになるまで 描画順にアルファベットを乗せると、不正解のルートができるようです。
( もっと精度よく、不正解のルートも適度に反映されるようにするのが課題となります。)
英語のキッズ教室で、幼児向けの…今からアルファベット順を 覚えましょう程度の遊び心を交えたものなら、そこまで難易度を あげる必要性は無いと思いますが….
尚、下記の添付画像のように正解ルートが2つに なる場合もございます。
Alphabet.Maze.正解ルートが2つ.JPG 74 KB ダウンロードURL: https://d.kuku.lu/59f11bdbd
■3. 実装コードの作成について ( 著作権 )
さて、ここまで閲覧いただけた方は、一番気になる処では ないかと思われます。
あなたが、全部のマクロを作成したのかって？
まさか…そんなことしたら軽く数年がかかりますよ。 それに今の私の実力では、出来るとも思えませんし…( 笑 )
では「タネあかし」を そうです。ズバリ! カンニングです。
（みみ）さんピックアップしてくれた中に、 著作権フリーの、改変、改造自由のマクロがありました。
元のマクロを走らせて、コードを眺めること5分 ほぼ、直感的に…これはいけそうだと思いました。 （みみ）さん...ありがとうございます。
↓どうでもいいプログラム研究所さんの、こちらです。 https://tdyu.hatenablog.jp/entry/2019/05/05/033730
製作者：tdyu5021さんの Twitter の中で 1:20 PM · Apr 24, 2019·Twitter Web App https://twitter.com/tdyu05/status/1120905406274887681?ref_src=twsrc%5Etfw%7Ctwcamp%5Etweetembed%7Ctwterm%5E1120905406274887681%7Ctwgr%5E86ab372e35c5c80b118eaa330bf084550189d4a1%7Ctwcon%5Es1_&ref_url=https%3A%2F%2Ftdyu.hatenablog.jp%2Fentry%2F2019%2F05%2F05%2F033730
なんだかバズっているので、エクセルファイル本体をおいておきますね（すみませんgithubとかやってないので） 自由に改変したりコードを改善していただけると嬉しいです。とおしゃってます。
(有)@tdyu05 さん、ありがとうございます。 早速、使わせていただきます。
■4. 実装コードのモジュールへの貼付け方 ( 各プロシージャについて )
な〜に、マクロを改変して意気込むようなことなどありません。 ただ、追加しただけで、正直言って…この書いている文章の方が よっぽど時間がかかりました。
質問者さんへ、もし閲覧されてればですが 最初から、全ての要望を満たす事をするのは難易度が高すぎです。 時間もどれだけ消費するかわかりませんので。
しかし、既存の完成品にちょいとアレンジして それとなく完成が見える処までこれば、あとは これから時間を使ってでもするかどうかを判断できます。
手はじめなので、この縮小版で十分かと思います。 マクロの各要素を変更していけば…きっと( 20列×20行のレイアウト )も完成が可能かと思います。
( 各プロシージャについて )
◇「迷路を自動で生成」マクロの構成
・Sub initializing() ・Sub move() ・Sub fillRoute(num As Integer) ・Function getDirectionNum(ByVal directionArray_ As Variant, sum2_ As Integer) As Integer
●元のマクロはこちら
Excel VBAでワークシート上に迷路を自動生成するマクロ https://tdyu.hatenablog.jp/entry/2019/05/05/033730
◇「迷路を自動で解く」マクロの構成
・Sub initializing02() ・Sub solveMaze(prevDirecNum_ As Integer) ・Function getDirectionArray(n As Integer) As Variant ・Function checkAround(nm_ As Integer) As Integer ・Sub drawRoute(Alphabet() As String) ・Sub writeNumber() ・Sub Borders_LineStyleON()
●元のマクロはこちら
Excelで作られた迷路を自動で解いて正答ルートを描画するマクロ https://tdyu.hatenablog.jp/entry/2019/05/07/022904
Module1へ、「迷路を自動で生成」マクロの構成を全て貼り付ける Module2へ、「迷路を自動で解く」マクロの構成を全て貼り付ける
【 マクロ実行手順 】説明はいらないと思われるが… 1. Sub initializing() 2. Sub initializing02() 3. Sub Borders_LineStyleON()
■5. 実装コードの添付 ( ちゃんと動くと思われる )
◇ 標準モジュール：Module1
Option Explicit Dim mazeArea As Range Dim currentPosition As Range Dim x As Integer, y As Integer Dim cnt As Integer Dim arr(11) As Variant Const limit = 4
Sub initializing()
Application.ScreenUpdating = False
'//埋まったセルの数を数えるをカウンタ
cnt = 0
'//迷路の範囲を定義&初期化
Set mazeArea = Range(Cells(2, 2), Cells(11, 11))
mazeArea.Clear
'//マスが埋まっているかいないかを1か0で判定するための配列を初期化
'//arr(0),arr(11),arr(i)がy座標（＝行）であり、Array(0,1)がx座標（＝列）
arr(0) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
arr(11) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
Dim i As Integer
For i = 1 To 10
arr(i) = Array(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1)
Next i
'//自分の最初の座標
x = 1
y = 1
'//道の描画（今いるセルに色と罫をつける）
Call fillRoute(1)
'//次に描画する道（セル）に移動
Call move
End Sub
Sub move()
Dim up As Integer, rt As Integer, bt As Integer, lf As Integer
Dim sum1 As Integer, sum2 As Integer
Dim a As Integer
Dim b As Integer
Dim n As Integer
Dim direction() As Integer
Dim directionArray As Variant
Dim xx As Integer
Dim stopFlg
Dim num
Randomize
'//セルを100個塗ったら作成終了
If cnt > 99 Then
mazeArea.Cells(1, 1).Borders(xlEdgeTop).LineStyle = xlNone
mazeArea.Cells(10, 10).Borders(xlEdgeBottom).LineStyle = xlNone
'*************************************************
Range("A:L").ColumnWidth = 4.15
Rows("1:11").RowHeight = 25
Range("A1:L11").HorizontalAlignment = xlCenter
With Range("B2").CurrentRegion
.Font.Name = "Meiryo UI"
.Font.Size = 14
End With
'*************************************************
Application.ScreenUpdating = True
Exit Sub
End If
'//隣のセルに移動できるかどうかを判定
up = arr(y - 1)(x)
bt = arr(y + 1)(x)
rt = arr(y)(x + 1)
lf = arr(y)(x - 1)
sum1 = up + bt + rt + lf
'//もし隣のセルがすべて埋まっていてこれ以上進めない場合、
'//あるいは、ゴールセルの1つ手前のセルに初めて来た場合に
'//新たな空白セルからスタート＋任意の方向の壁を開通
If (sum1 = limit) Or (((y = 9 And x = 10) Or (y = 10 And x = 9)) And stopFlg = False) Then
If (y = 9 And x = 10) Or (y = 10 And x = 9) Then stopFlg = True
Dim i As Integer, j As Integer
For i = 1 To 10
For j = 1 To 10
If arr(i)(j) = 0 Then
up = arr(i - 1)(j)
bt = arr(i + 1)(j)
rt = arr(i)(j + 1)
lf = arr(i)(j - 1)
'//現在地セルの周りが何方向埋まっているかの数を格納
sum2 = up + bt + rt + lf
'//埋まっている方向（の番号）を配列に入れる
ReDim direction(sum2 - 1) As Integer
xx = 0
If up = 1 Then
direction(xx) = 3 '//上方向が埋まってる場合
xx = xx + 1
End If
If bt = 1 Then
direction(xx) = 1 '//下方向が埋まってる場合
xx = xx + 1
End If
If rt = 1 Then
direction(xx) = 4 '//右方向が埋まってる場合
xx = xx + 1
End If
If lf = 1 Then
direction(xx) = 2 '//左方向が埋まってる場合
End If
y = i
x = j
Select Case sum2
Case 1
fillRoute (direction(xx))
Case 2
directionArray = Array(direction(0), direction(1))
Case 3
directionArray = Array(direction(0), direction(1), direction(2))
Case 4
directionArray = Array(direction(0), direction(1), direction(2), direction(3))
End Select
'//壁を開通させる方向を取得する関数
num = getDirectionNum(directionArray, sum2)
'//次の道を描画
fillRoute (num)
If Not cnt > 99 Then Call move
Exit For
End If
Next j
Next i
End If
'//次に進む方向を決定
n = Int(Rnd * 4) + 1
Select Case n
Case 1 '//上
'//もし移動先が進めないセルだったら進む方向は決定せず再帰
If y = 1 Or arr(y - 1)(x) = 1 Then
Call move
Exit Sub
Else
a = -1
b = 0
End If
Case 2 '//右
If x = 10 Or arr(y)(x + 1) = 1 Then
Call move
Exit Sub
Else
a = 0
b = 1
End If
Case 3 '//下
If y = 10 Or arr(y + 1)(x) = 1 Then
Call move
Exit Sub
Else
a = 1
b = 0
End If
Case 4 '//左
If x = 1 Or arr(y)(x - 1) = 1 Then
Call move
Exit Sub
Else
a = 0
b = -1
End If
End Select
'//次の道の座標
y = y + a
x = x + b
'//次の道を描画
Call fillRoute(n)
'//Application.Wait [Now() + "0:00:00.1"] '//デバッグ用。描画の様子を1マスずつ確認するため
Call move
End Sub
Sub fillRoute(num As Integer)
'**************************************************************
Dim Alphabet
Dim i&, q&, k&
Alphabet = _
Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z," & _
"A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z," & _
"A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z," & _
"A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V", ",") '' 100コ
mazeArea.Cells(y, x) = Alphabet(cnt)
'' For k = 0 To cnt
'' mazeArea.Cells(y, x) = Alphabet(k)
'' Next
'' Debug.Print Alphabet(cnt), mazeArea.Cells(y, x).Address
Rem test デバッグ用にワークシートに書き出し
'' Cells(cnt + 2, 13) = Alphabet(cnt)
'' Cells(cnt + 2, 14) = mazeArea.Cells(y, x).Address
'' Cells(cnt + 2, 15) = num
'**************************************************************
Set currentPosition = mazeArea.Cells(y, x)
With currentPosition
.BorderAround Weight:=xlThick, LineStyle:=xlContinuous
Select Case num
Case 1
.Borders(xlEdgeBottom).LineStyle = xlNone
Case 2
.Borders(xlEdgeLeft).LineStyle = xlNone
Case 3
.Borders(xlEdgeTop).LineStyle = xlNone
Case 4
.Borders(xlEdgeRight).LineStyle = xlNone
End Select
.Interior.ColorIndex = xlAutomatic
.Interior.Pattern = xlCrissCross
.Interior.PatternThemeColor = xlThemeColorAccent4
.Interior.PatternTintAndShade = 0.6
End With
'//描画済みの座標をフラグオン
arr(y)(x) = 1
cnt = cnt + 1
End Sub
Function getDirectionNum(ByVal directionArray_ As Variant, sum2_ As Integer) As Integer
'/*壁を開通する方向を決定する関数*/
Dim n As Integer, directionNum As Integer, flg As Boolean
Randomize
Do
n = Int(Rnd * sum2_)
directionNum = directionArray_(n)
If y = 1 And directionNum = 3 Then
flg = True
ElseIf y = 10 And directionNum = 1 Then
flg = True
ElseIf x = 1 And directionNum = 2 Then
flg = True
ElseIf x = 10 And directionNum = 4 Then
flg = True
Else
flg = False
End If
Loop While flg = True
getDirectionNum = directionNum
End Function
◇ 標準モジュール：Module2
Option Explicit Dim mazeArea As Range Dim y(100) As Integer, x(100) As Integer Dim nm As Integer Dim flgArr(11) As Variant Dim routeArr(100) As Variant Dim routeCounter As Integer Dim stopFlg(100) As Boolean Dim goalFlg As Boolean Dim backFlg As Integer
Sub initializing02()
Dim prevDirecNum As Integer
Dim h As Integer, i As Integer, j As Integer, cnt As Integer
Dim yy As String, xx As String
'//迷路の範囲を定義
Set mazeArea = Range(Cells(2, 2), Cells(11, 11))
'//行き止まりに達したとき前々回の分岐まで戻るかどうかを判断するフラグ
'//（配列変数を動的に増やすのが面倒なのでとりあえず100個くらいつくっておく）
For h = 0 To 100
stopFlg(100) = False
Next h
'//マスが埋まっているかいないかを1か0で判定するための配列
flgArr(0) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
flgArr(11) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
For i = 1 To 10
flgArr(i) = Array(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1)
Next i
'//ゴールしたらオンにするフラグ
goalFlg = False
'//nmは分岐から分岐までの番号
'//routeCounterは分岐から分岐まで進んだ座標を格納するループカウンタ
nm = 0
routeCounter = 0
'//要素数100個の空の2次元配列を作っておく。ここに確定ルートの座標を格納していく
For j = 0 To 100
Dim a As Variant
Dim b
a = Array("")
b = ""
cnt = 0
Do Until cnt = 100
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = b
cnt = cnt + 1
Loop
routeArr(j) = a
Next j
'//座標の初期値
y(nm) = 1
x(nm) = 1
'//すでに通った座標にフラグオン
flgArr(y(nm))(x(nm)) = 1
Call writeNumber '//デバッグ用（迷路上のセルにnmを書き出す）
'//確定したルートの座標を格納。セルオブジェクトは配列に入れられないのでyx座標をyyxxの形で文字列で格納しておく */
If y(nm) < 10 Then
yy = "0" + "" + CStr(y(nm))
Else
yy = CStr(y(nm))
End If
If x(nm) < 10 Then
xx = "0" + "" + CStr(x(nm))
Else
xx = CStr(x(nm))
End If
routeArr(nm)(routeCounter) = yy + "" + xx
routeCounter = routeCounter + 1
'/* 確定ルートの配列化はここまで */
'//次進むセルからみて、今自分がいる方向の番号（1:上、2:右、3：下、4：左）
prevDirecNum = 1
Call solveMaze(prevDirecNum)
End Sub
Sub solveMaze(prevDirecNum_ As Integer)
Dim ii As Integer
Dim wallNum As Integer
Dim prevDirecNum_2 As Integer
Dim arr, newNm, yy, xx
If goalFlg = True Then Exit Sub
'********************************************
Dim i&, q&, n&
Dim Alphabet(103) As String
For q = 1 To 4
For i = 1 To 26
n = n + 1
Alphabet(n - 1) = Chr(Asc("A") + i - 1)
Next i
Next q
'********************************************
'//ゴールの座標に来たら終了
If y(nm) = 10 And x(nm) = 10 Then
Call drawRoute(Alphabet)
goalFlg = True
Exit Sub
End If
'//壁がない方向を調べて配列に入れる
arr = getDirectionArray(prevDirecNum_)
'//壁がない方向の数を変数に入れる
If arr(0) = "" Then
wallNum = 0
ElseIf arr(1) = "" Then
wallNum = 1
Else
wallNum = 2
End If
'//壁に接しない面が0箇所の場合（＝行き止まりの場合）
If wallNum = 0 Then
routeCounter = 0
'//backFlgが0なら前の分岐に。1ならそれより前の分岐を調べて戻る
If backFlg = 0 Then
y(nm) = y(nm - 1)
x(nm) = x(nm - 1)
ElseIf backFlg = 1 Then
If stopFlg(nm) = True Then
newNm = checkAround(nm)
nm = newNm + 1
y(nm) = y(newNm)
x(nm) = x(newNm)
End If
End If
'//壁に接しない面が1箇所（前回自分がいた方向は除いて）の場合
ElseIf wallNum = 1 Then
'//次に進む方向を決定する＆その移動先から見て自分がいた方向の番号を変数に
Select Case arr(0)
Case 1
y(nm) = y(nm) - 1
prevDirecNum_2 = 3 '//下
Case 2
x(nm) = x(nm) + 1
prevDirecNum_2 = 4 '//左
Case 3
y(nm) = y(nm) + 1
prevDirecNum_2 = 1 '//上
Case 4
x(nm) = x(nm) - 1
prevDirecNum_2 = 2 '//右
End Select
'//すでに通った座標にフラグオン
flgArr(y(nm))(x(nm)) = 1
Call writeNumber '//デバッグ用（迷路上のセルにnmを書き出す）
If y(nm) < 10 Then
yy = "0" + "" + CStr(y(nm))
Else
yy = CStr(y(nm))
End If
If x(nm) < 10 Then
xx = "0" + "" + CStr(x(nm))
Else
xx = CStr(x(nm))
End If
routeArr(nm)(routeCounter) = yy + "" + xx
routeCounter = routeCounter + 1
'//再帰
Call solveMaze(prevDirecNum_2)
'//壁に接しない面が2箇所（前回自分がいた方向は除いて）の場合
ElseIf wallNum = 2 Then
nm = nm + 1
routeCounter = 0
y(nm) = y(nm - 1)
x(nm) = x(nm - 1)
For ii = 0 To 1
'//ゴールしているなら終了
If goalFlg = True Then Exit For
For xx = 0 To 100
routeArr(nm)(xx) = ""
Next xx
'//もし2つに分かれている道で2経路とも探索が終わったらフラグを立てる
If ii = 1 Then
backFlg = 1
stopFlg(nm) = True
Else
backFlg = 0
End If
Select Case arr(ii)
Case 1
y(nm) = y(nm) - 1
prevDirecNum_2 = 3
Case 2
x(nm) = x(nm) + 1
prevDirecNum_2 = 4
Case 3
y(nm) = y(nm) + 1
prevDirecNum_2 = 1
Case 4
x(nm) = x(nm) - 1
prevDirecNum_2 = 2
End Select
'//すでに通った座標にフラグオン
flgArr(y(nm))(x(nm)) = 1
Call writeNumber '//デバッグ用（迷路上のセルにnmを書き出す）
If y(nm) < 10 Then
yy = "0" + "" + CStr(y(nm))
Else
yy = CStr(y(nm))
End If
If x(nm) < 10 Then
xx = "0" + "" + CStr(x(nm))
Else
xx = CStr(x(nm))
End If
routeArr(nm)(routeCounter) = yy + "" + xx
routeCounter = routeCounter + 1
'//再帰
Call solveMaze(prevDirecNum_2)
Next ii
End If
End Sub
Function getDirectionArray(n As Integer) As Variant
'/* 次に進める方向を配列に入れるための関数 */
Dim i As Integer
Dim direction As Variant
i = 0
direction = Array("", "", "", "")
With mazeArea
If .Cells(y(nm), x(nm)).Borders(xlEdgeTop).LineStyle = xlNone Then
If n <> 1 Then
direction(i) = 1
i = i + 1
End If
End If
If .Cells(y(nm), x(nm)).Borders(xlEdgeRight).LineStyle = xlNone Then
If n <> 2 Then
direction(i) = 2
i = i + 1
End If
End If
If .Cells(y(nm), x(nm)).Borders(xlEdgeBottom).LineStyle = xlNone Then
If n <> 3 Then
direction(i) = 3
i = i + 1
End If
End If
If .Cells(y(nm), x(nm)).Borders(xlEdgeLeft).LineStyle = xlNone Then
If n <> 4 Then
direction(i) = 4
i = i + 1
End If
End If
getDirectionArray = direction
End With
End Function
Function checkAround(nm_ As Integer) As Integer
'/* すでに通った分岐（別れ道）の中から、進める方向が残っている分岐を探す関数 */
Dim i As Integer
Dim mySum As Integer
For i = nm_ - 1 To 0 Step -1
mySum = 0
If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeTop).LineStyle <> xlNone Or _
flgArr(y(i) - 1)(x(i)) = 1 Then
mySum = mySum + 1
End If
If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeRight).LineStyle <> xlNone Or _
flgArr(y(i))(x(i) + 1) = 1 Then
mySum = mySum + 1
End If
If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeBottom).LineStyle <> xlNone Or _
flgArr(y(i) + 1)(x(i)) = 1 Then
mySum = mySum + 1
End If
If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeLeft).LineStyle <> xlNone Or _
flgArr(y(i))(x(i) - 1) = 1 Then
mySum = mySum + 1
End If
If mySum < 4 Then
checkAround = i
Exit For
End If
Next i
End Function
Sub drawRoute(Alphabet() As String)
'/*確定したルートの座標を格納した配列を一気に色付け */
Dim n&
Dim i As Integer, j As Integer, yy As Integer, xx As Integer
Dim rowEnd As Integer
For i = 0 To nm
' rowEnd = 2
For j = 0 To 100
If routeArr(i)(j) = "" Then Exit For
yy = Val(Left(routeArr(i)(j), 2))
xx = Val(Right(routeArr(i)(j), 2))
' Cells(rowEnd, 14 + i).Value = routeArr(i)(j) '//デバッグ用にワークシートに書き出し
' rowEnd = rowEnd + 1
mazeArea.Cells(yy, xx).Interior.Color = RGB(255, 255, 0)
'********************************************
n = n + 1
mazeArea.Cells(yy, xx) = Alphabet(n - 1)
'********************************************
Next j
Next i
End Sub
Sub writeNumber()
'Dim currentPosition As Range
'Set currentPosition = mazeArea.Cells(y(nm), x(nm))
'currentPosition.Value = nm
End Sub
**************************************************************
Sub Borders_LineStyleON()
With Range("B2").CurrentRegion
.Borders.LineStyle = True
.BorderAround Weight:=xlThick
.Interior.ColorIndex = xlAutomatic
.Interior.Pattern = xlCrissCross
.Interior.PatternThemeColor = xlThemeColorAccent4
.Interior.PatternTintAndShade = 0.6
End With
End Sub
**************************************************************
※因みに、追加したコード部分は、ほんの数行で ******************************************** このエリアになります。 ******************************************** 追記した変数宣言部分と、値渡しの箇所は説明を割愛します。
■6. 今後の取り組みについて
年内に( 20列×20行のレイアウト )を完成を目指すことは 私にはできません。う〜ん、多分^^; … 実力不足と、時間も足りないので
閲覧いただいた方の中で、サクッとしていただける方が いましたら、よろしくお願いします。
また、追加したマクロ部分で、この方が良いよ と言ったご指摘がありましたら、ご指導を宜しくお願いします。
■7. どうでもいい話
「 迷路を自動で生成して自動で正答ルートを色付けする 」マクロは、 どうでもいいプログラム研究所の…どうでもいいVBAマクロシリーズの中の どうでもいいマクロのようですが。。。
私、個人的には...こちらのどうでもいいマクロが、素敵だと思います。(*´艸`) ↓ 数式や関数を打ち間違えるとニコニコ動画風に煽ってくるExcel VBAマクロの作り方 https://tdyu.hatenablog.jp/entry/2020/05/26/001420
tdyu5021さんが、この記事を閲覧したら お前〜ん何回「 どうでもいい 」を連呼するんだと 叱られそうなので…これで終了します。 (o_ _)o ﾍﾟｺ
最後まで御覧戴きまして、誠にありがとうございます。
（あみな） 2022/10/26(水) 16:02:15
あみなさんの労作拝見しました。うまくいっていると思いました。
経路に沿ってA〜Zというのだと、普通の人には簡単すぎるかもしれませんね。 子供向けのものであれば、ALPHABETの順序を覚えるのに適しているかもしれませんね。
遅ればせながら、全域木を使った迷路作成とその解法にトライしてみました。
■シート ・Sheet1 迷路を表示します。 ・Sheet2 作業用シート
■ボタンに登録するとよいマクロ
Caption マクロ名 概要
============== ====== ================================================
(1)迷路を作る main 20*20の迷路を作成します（行/列の数はコード内の定数で変更できます）
(2)迷路を解く main2 迷路を解いて、パスを黄色の塗りつぶしで表示します。
(3)解を消す path消去 黄色を消します。
(4)文字列表示 文字列表示 解の経路にAlphabetをA〜Zの順で書き込みます。（他セルはランダム）
・(1)→(2) で、壁有りの通常の迷路とその解を表示できます。
・さらに (4)を実行することで、Alphabet Mazeに書き換えできます。(罫線を消し、Alphabetを挿入）
・(3)を実行すると、解のパス（黄色）を消すことができます。
・元の黄色に戻すには、(2)を再実行します。
Alphabet を数値に変えたりといったところは、自由に変更していただいて構いません。
■参考コード 以下を標準モジュールにコピーペイストしてください。
=========================== Option Explicit
Const r As Long = 20 '迷路の行数 ■適宜修正可 (99まで可能だが時間がかかります） Const c As Long = 20 '迷路の列数 ■適宜修正可 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim edge As Object Dim tree As Object Dim path$ Const MaxSize = 200 'キューのサイズ Dim queue(MaxSize) 'キュー Dim head&, tail& 'キューの先頭、終端へのポインタ
Sub main()
Application.ScreenUpdating = False
Set ws1 = Worksheets("Sheet1") '迷路表示用シート ■シート名は必要に応じて修正可
Set ws2 = Worksheets("Sheet2") '作業用シート ■シート名は必要に応じて修正可
Set edge = CreateObject("Scripting.Dictionary")
ws2.UsedRange.ClearContents
Randomize
'' Rnd (-1) '乱数固定(debug用）の場合は上に代えて
Set tree = 迷路作成
Call 迷路表示(tree)
Application.ScreenUpdating = True
End Sub
Sub main2()
Application.ScreenUpdating = False
path = 迷路を解く(tree)
Call path表示(path)
Application.ScreenUpdating = True
End Sub
Function 迷路作成() As Object
'全域木を使った迷路作成（Kruskal法）
Dim grouping As Object
Dim mat As Variant
Dim n1$, n2$
Dim gLow&, gHigh&, gmax&
Dim g1&, g2&
Dim s$
Dim e
Dim k&
Call make_edge
mat = mySort(edge) 'edgeをweightの昇順で並び替え
' mat（(n,2)配列): 1列目は edge("0101-0102"のような）
' 2列目は weight ([0,1]内の乱数）
' weightの昇順にソート済み
Set tree = CreateObject("Scripting.Dictionary")
Set grouping = make_vertex_like_dic(Empty)
'各vertexごとに連結していたら同一group番号を付与するためのdictionary
'各edgeを一つずつ見て、通路となる部分を増やしていく
'連結したgroup内の頂点を結んでしまうと閉路にならので、それを除外することに注意。
'また、新たに連結したnodeには同一のgroup番号を付与する調整を行う。
For k = 1 To UBound(mat, 1)
s = mat(k, 1)
n1 = Split(s, "-")(0) 'node1のつもり(vertexとnodeが混在してしまって分かりにくいかも)
n2 = Split(s, "-")(1) 'node2のつもり
g1 = grouping(n1)
g2 = grouping(n2)
If g1 = 0 And g2 = 0 Then
gmax = gmax + 1
grouping(n1) = gmax
grouping(n2) = gmax
tree(s) = Empty
ElseIf g1 = 0 And g2 > 0 Then
grouping(n1) = g2
tree(s) = Empty
ElseIf g1 > 0 And g2 = 0 Then
grouping(n2) = g1
tree(s) = Empty
ElseIf g1 <> g2 Then '同じgroup内のvertexを結ぶと閉路が生じるので、それは除外
tree(s) = Empty
'n1とn2を連結したので、同一グループになる。それに伴ってgroup番号を更新。
gLow = WorksheetFunction.Min(g1, g2)
gHigh = WorksheetFunction.Max(g1, g2)
For Each e In grouping
If grouping(e) = gHigh Then
grouping(e) = gLow
End If
Next
End If
gmax = WorksheetFunction.Max(grouping.items)
Next
Set 迷路作成 = tree
End Function
Function make_edge()
Dim j&, k&, p&
Dim s$
'(1)いったんありうるすべてのedgeを列挙し、それぞれにランダムなweightをつける
For j = 1 To r '横方向のedge
For k = 1 To c - 1
s = Format(j, "00") & Format(k, "00") & "-" & Format(j, "00") & Format(k + 1, "00")
edge(s) = Rnd
Next
Next
For j = 1 To r - 1 '縦方向のedge
For k = 1 To c
s = Format(j, "00") & Format(k, "00") & "-" & Format(j + 1, "00") & Format(k, "00")
edge(s) = Rnd
Next
Next
'(2)始点と終点は特別なweightをつける
Dim p1$, p2$, p3$, p4$
'始点(左上隅)からのedge
p1 = "0101-0102": p2 = "0101-0201"
'終点(右下隅)へのedge
p3 = Format(r, "00") & Format(c - 1, "00") & "-" & Format(r, "00") & Format(c, "00")
p4 = Format(r - 1, "00") & Format(c, "00") & "-" & Format(r, "00") & Format(c, "00")
If Rnd < 0.5 Then 'ランダムに出発の方向を変える
edge(p1) = 1#: edge(p2) = 0#
Else
edge(p1) = 0#: edge(p2) = 1#
End If
If Rnd < 0.5 Then
edge(p3) = 1#: edge(p4) = 0#
Else
edge(p3) = 0#: edge(p4) = 1#
End If
End Function
Function mySort(edge) As Variant
'手抜いて、シート上に展開してソート（weightによる昇順)
ws2.[A1].Resize(edge.Count, 1) = Application.Transpose(edge.keys)
ws2.[B1].Resize(edge.Count, 1) = Application.Transpose(edge.items)
ws2.[A1].CurrentRegion.Sort key1:=ws2.[B1], order1:=xlAscending
mySort = ws2.[A1].CurrentRegion.Value
End Function
Function make_vertex_like_dic(a As Variant)
Dim j&, k&, s$
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For j = 1 To r
For k = 1 To c
s = Format(j, "00") & Format(k, "00")
dic(s) = a
Next
Next
Set make_vertex_like_dic = dic
End Function
Sub 迷路表示(tree As Object)
Dim mat As Variant
Dim s$, s1$, s2$, r1&, r2&, c1&, c2&
Dim k&
With ws1.[A1].Resize(r, c)
.ClearContents
.Borders.LineStyle = True
.Borders.Weight = xlThick
.BorderAround Weight:=xlThick
.Interior.ThemeColor = xlThemeColorAccent4
.Interior.TintAndShade = 0.799981688894314
End With
mat = tree.keys
For k = 0 To UBound(mat)
s = mat(k)
s1 = Split(s, "-")(0)
s2 = Split(s, "-")(1)
r1 = CLng(Left(s1, 2))
c1 = CLng(Right(s1, 2))
r2 = CLng(Left(s2, 2))
c2 = CLng(Right(s2, 2))
If r1 = r2 Then
ws1.Cells(r1, c1).Borders(xlEdgeRight).LineStyle = xlNone
Else
ws1.Cells(r2, c2).Borders(xlEdgeTop).LineStyle = xlNone
End If
Next
End Sub
Function 迷路を解く(tree As Object) As String
Dim path As String
Dim 隣接集合 As Object 'dictionary
Dim tracer As Object 'dictionary
Dim startpoint$, endpoint$
Dim 隣接node$
Dim vtx, vtx2
Dim p$
startpoint = "0101"
endpoint = Format(r, "00") & Format(c, "00")
Set 隣接集合 = 隣接集合の作成(tree.keys)
'隣接集合はdictinnary
' key: node
' item: nodeと結ばれているnodeたちをvbTabでJoinしたもの
Set tracer = CreateObject("Scripting.Dictionary")
'tracerは、それがどこから来たかを管理するdictinary
enqueue startpoint 'キューに始点を入れる
tracer(startpoint) = startpoint
Do While tail <> head
dequeue vtx 'キューからvtxに要素を一つ取り出す
隣接node = 隣接集合(vtx)
For Each vtx2 In Split(隣接node, vbTab)
If Not tracer.exists(vtx2) Then
tracer(vtx2) = vtx
enqueue vtx2
'終点まで到達したら、tracerを使ってpathを再現
If vtx2 = endpoint Then
path = endpoint
Do While Not Left(path, 4) = startpoint
p = tracer(Left(path, 4))
path = p & "-" & path
Loop
End If
End If
Next
Loop
迷路を解く = path
End Function
Function 隣接集合の作成(mat) As Object
Dim dic As Object
Dim s
Dim n1$, n2$
Set dic = CreateObject("Scripting.Dictionary")
For Each s In mat
n1 = Split(s, "-")(0)
n2 = Split(s, "-")(1)
If Not dic.exists(n1) Then
dic(n1) = n2
Else
dic(n1) = dic(n1) & vbTab & n2
End If
If Not dic.exists(n2) Then
dic(n2) = n1
Else
dic(n2) = dic(n2) & vbTab & n1
End If
Next
Set 隣接集合の作成 = dic
End Function
'n を キューへ入力
Function enqueue(n As Variant) As Variant
If (tail + 1) Mod MaxSize <> head Then
queue(tail) = n
tail = tail + 1
tail = tail Mod MaxSize
enqueue = 0
Else
enqueue = -1
End If
End Function
'キューから n に 取り出し
Function dequeue(n As Variant) As Variant
If tail <> head Then
n = queue(head)
head = head + 1
head = head Mod MaxSize
dequeue = 0
Else
dequeue = -1
End If
End Function
'pathを元に、その経路を黄色で塗りつぶす
Sub path表示(path As String)
Dim mat As Variant 'ローカルなので注意
Dim s$, r1&, c1&
Dim k&
mat = Split(path, "-")
For k = 0 To UBound(mat, 1)
s = mat(k)
r1 = CLng(Left(s, 2))
c1 = CLng(Right(s, 2))
ws1.Cells(r1, c1).Interior.Color = vbYellow
Next
End Sub
'背景色を元の色に戻す
Sub path消去()
With ws1.[A1].Resize(r, c)
.Interior.ThemeColor = xlThemeColorAccent4
.Interior.TintAndShade = 0.799981688894314
End With
End Sub
'全セルにランダムなAlphabetを書き込んだのち、
'始点から終点までにAlphabetを順に書き込む。
Sub 文字列表示()
Dim e As Range
Dim mat As Variant
Dim k&, r1&, c1&, s$
For Each e In ws1.[A1].Resize(r, c)
e.Value = Chr(Application.RandBetween(65, 90))
Next
mat = Split(path, "-")
For k = 0 To UBound(mat, 1)
s = mat(k)
r1 = CLng(Left(s, 2))
c1 = CLng(Right(s, 2))
ws1.Cells(r1, c1).Value = Chr(65 + (k Mod 26))
Next
ws1.[A1].Resize(r, c).Borders.LineStyle = xlNone
End Sub
以下が参考になるかもしれません。 「全域木を用いた迷路生成法」 https://www.amusement-creators.info/articles/advent_calendar/2019/11_0/ クラスカル法(Wikipedea) https://ja.wikipedia.org/wiki/%E3%82%AF%E3%83%A9%E3%82%B9%E3%82%AB%E3%83%AB%E6%B3%95
なお、全域木を用いた迷路生成は、他の方法（棒倒し法、壁伸ばし法、穴掘り法等）に比べて なんというか精度が低いというか、陰影が乏しいというかそんな気がして、ロジックの間違いかと 逡巡しました。 少し検証しましたが明確なロジックの間違いではなく、たぶん方法の特徴だろうと観念して、 記載して一段落させることにしました。
VBAで全域木を用いた迷路作成に興味をお持ちの方の参考になれば幸いです。 （γ） 2022/10/26(水) 22:24:42
（γ）さんの「全域木を用いた迷路生成法」を拝見した感想。。。
Dictionary であ〜だこ〜だして…最後にポーンって出力 とんでもなく難しいです。。o゜ヤバ(p´□`q)ヤバ゜o 。
あなたが、勉強不足なだけですって？…そうなんですが （γ）さんの説明付きなのですが、VBA初心者の私には…
まだ、どちらかと言えば、tdyu5021さんのマクロの方が 初心者でも、分解すればなんとか読める印象です。
と、この場を借りて…先日の（あみな） 2022/10/26(水) 16:02:15 のUPした マクロですが、Sub initializing() で実行するボタンが揺れすぎてしまいました。
下記の入れるところを、間違えてました。アンポンですいません。(o_ _)o ﾍﾟｺ
Sub move()
〜 略 〜
'*************************************************
Range("A:L").ColumnWidth = 4.15
Rows("1:11").RowHeight = 25
Range("A1:L11").HorizontalAlignment = xlCenter
With Range("B2").CurrentRegion
.Font.Name = "Meiryo UI"
.Font.Size = 14
End With
'*************************************************
〜 略 〜
End Sub
普通にここへ入れてください。 ↓
Sub initializing()
〜 略 〜
'//次に描画する道（セル）に移動
Call move
◆このへんが、居心地がよさそうです。
End Sub
（あみな） 2022/10/27(木) 11:03:19
コメントありがとうございました。
そうですよね、引数渡しにしたり、モジュールレベル変数にしたりして 統一性がなく（ボタンに登録することを考えると、関数にはできないので）、 分かりにくいものになってしまったかもしれません。
考え方自体を説明していないので理解しにくいですよね。若干の補足をしておきます。
このコードは大きく二つの部分（迷路の作成部分と迷路の解法部分）に分かれます。
●迷路作成
縦10横10の迷路を例に説明します。
・頂点（これは各セルの中点と考えてもらって結構です）は10*10で100個あり
・隣り合う頂点を結ぶ結んだ辺は、
・10*9個の 横方向の辺、
・9*10個の 縦方向の辺、の計180本がありえます。
（右に行くのと左に行くのでは最終的な経路は違いますが、
迷路を作るうえでは区別する必要がありません）
・これらの180個の辺のうちの一部を使って、
・100個の頂点はすべて必ず結ばれていて、しかも
・閉路は無いもの
を作ることができます、これが「全域木」と呼ばれるものです。
「迷路をひとつ作ること」は、「ひとつの全域木を作ること」と同値なことが知られているので、 乱数を使って、全域木を作る作業を通じて、迷路をランダムに生成しているわけです。
で、180個ある辺のなかからランダムに一つずつ取り出して（これは辺にweightと呼んだ一様乱数を割り当て、 その昇順に取り出します）、順次、通路からなる木を増殖していきます。
注意するのは、 ・連結している木は、頂点に同一のグループ番号を振っておいて、 同じグループ番号が振ってある頂点どうしを結ばないようにする点です。 なぜかというと、これをやってしまうと、通路が閉路になって、堂々巡りになってしまうからです。 ・そして、連結するたびに二つのグループの小さい方のグループ番号(ただし0ではない）に更新していきます。 ・これをすべての辺について実行すると、最終的には、すべての頂点が結ばれた木（全域木）が得られます。
●最短路の決定（迷路を解く部分） 次にやるのは、こうして得られた木（通路を結んだもの）をもとにして、 始点と終点を結ぶ最短の経路を求めることになります。 これは比較的よく知られたダイクストラ法を使うことでできます。
処理で時間がかかるのは、前半の迷路作成のところですね。最短パスの検索は比較的早くできます。 （γ） 2022/10/27(木) 22:24:34
Public 起点_行 As Long, 起点_列 As Long, サイズ_行 As Long, サイズ_列 As Long, サイズ As Long, NowR As Long, NowC As Long
Public 終点_行 As Long, 終点_列 As Long
Public 起点 As Range, 終点 As Range, Meiro As Range
'--- 共通データの設定
Sub DataSet()
起点_行 = 2
起点_列 = 2
サイズ_行 = 20
サイズ_列 = 20
サイズ = サイズ_行 * サイズ_列
終点_行 = 起点_行 + サイズ_行 - 1
終点_列 = 起点_列 + サイズ_列 - 1
Set 起点 = Cells(起点_行, 起点_列)
Set 終点 = Cells(終点_行, 終点_列)
Set Meiro = Range(起点, 終点)
NowR = 起点_行
NowC = 起点_列
End Sub
'---------- Ver 1.0 : 1999.11.23
Sub 作業範囲クリア(Rs, Cs)
With Range(Cells(Rs, Cs), Cells.SpecialCells(xlLastCell))
' .ClearContents
.Borders(xlLeft).LineStyle = xlNone
.Borders(xlRight).LineStyle = xlNone
.Borders(xlTop).LineStyle = xlNone
.Borders(xlBottom).LineStyle = xlNone
.Interior.ColorIndex = xlNone
End With
End Sub
Sub Ini01()
Call DataSet
Call 作業範囲クリア(起点_行, 起点_列)
'--- 初期罫線作成
With Meiro
.Borders(xlInsideHorizontal).Weight = xlHairline
.Borders(xlInsideVertical).Weight = xlHairline
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlThin
.RowHeight = 13.5
.ColumnWidth = 2
End With
End Sub
Sub 迷路作成() '-- 迷路の作成
Call Ini01
'--- Ini データ_初期値のセット
Meiro.Interior.ColorIndex = xlNone
Select Case WorksheetFunction.Sum(Meiro)
Case 0: Meiro.Value = 1 '--優先（正解ルートなし）
Case Else: Meiro.Replace What:="", Replacement:=1, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False '--優先(正解ルートあり)
End Select
'--- パラメータセット
ReDim WdR(サイズ)
ReDim WdC(サイズ)
'---
起点.ClearContents
起点.Borders(xlTop).LineStyle = xlNone '-- 起点の処理
終点.Borders(xlRight).LineStyle = xlNone '-- 終点の処理
i = 1: WdR(i) = NowR: WdC(i) = NowC '-- 現在位置の記録
'--- 迷路作成
For j = 1 To サイズ_行 * サイズ_列
NowR = WdR(j): NowC = WdC(j)
Do
WStr = 進行調査(NowR, NowC) '-- 移動可能調査
No = Len(WStr)
If No = 0 Then
Exit Do '-- 移動不能ならExit
Else '-- ランダムに一歩前進
muki = 方向決定(No, WStr)
Set 現点 = Cells(NowR, NowC)
Select Case UCase(muki) '-- 罫線削除
Case "U": 現点.Borders(xlEdgeTop).LineStyle = xlNone: NowR = NowR - 1
Case "D": 現点.Borders(xlEdgeBottom).LineStyle = xlNone: NowR = NowR + 1
Case "R": 現点.Borders(xlEdgeRight).LineStyle = xlNone: NowC = NowC + 1
Case "L": 現点.Borders(xlEdgeLeft).LineStyle = xlNone: NowC = NowC - 1
End Select
'-- 前進先の処理
Cells(NowR, NowC).ClearContents
i = i + 1: WdR(i) = NowR: WdC(i) = NowC '-- 現在位置の記録
End If
Loop
Next
End Sub
'-- 移動可能調査文字列
Function 進行調査(Wr, Wc)
W9 = ""
'-- 値が{0}ならば移動不可
'-- 値が{1}ならば移動可能
If Cells(Wr - 1, Wc).Value = 1 Then W9 = W9 + "U"
If Cells(Wr + 1, Wc).Value = 1 Then W9 = W9 + "D"
If Cells(Wr, Wc + 1).Value = 1 Then W9 = W9 + "R"
If Cells(Wr, Wc - 1).Value = 1 Then W9 = W9 + "L"
'-- 値が{2}ならば決定（一筆モード）
If Cells(Wr - 1, Wc).Value > 1 Then W9 = "U"
If Cells(Wr + 1, Wc).Value > 1 Then W9 = "D"
If Cells(Wr, Wc + 1).Value > 1 Then W9 = "R"
If Cells(Wr, Wc - 1).Value > 1 Then W9 = "L"
進行調査 = W9
End Function
'----- ランダムに進行方向の文字列を返す
'-- 1,2,3,4 = 上下左右
Function 方向決定(No, WStr)
Randomize
W = Int((No * Rnd) + 1)
方向決定 = Mid(WStr, W, 1)
End Function
（チオチモリン） 2022/10/29(土) 17:17:27
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.