Results of 1 - 1 of about 37667 for IF (0.008 sec.)
- [[20221022080323]]
- #score: 1591
- @digest: 8502065a33c47571efdd774bed0a56f5
- @id: 92597
- @mdate: 2022-10-29T08:17:27Z
- @size: 61472
- @type: text/plain
- #keywords: 迷路 (214138), nrng (154070), mazearea (145362), 点_ (121797), prevdirecnum (121718), alphabet (121034), direction (104087), routecounter (100239), 路作 (75453), routearr (73808), 域木 (72681), ズ_ (56557), grouping (52861), 全域 (50279), 路を (49763), linestyle (46961), borders (43584), edge (36868), xlthin (36559), weight (33401), xlcontinuous (30764), xlautomatic (28935), 終点 (26905), xledgetop (22956), xledgeright (22051), xledgeleft (21576), xledgebottom (18268), 起点 (18247), nm (16755), 隣接 (14307), 座標 (12539), integer (11892)
- 『迷路って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 ＞ ---- 私には頭がパンクして無理ですが、再帰処理を使うんじゃないかな? それ専門の所を探してみた方が速いのでは? （不思議） 2022/10/22(土) 09:07:10 ---- VBA 迷路作成 で検索してみては? （検索補助） 2022/10/22(土) 11:01:44 ---- https://tdyu.hatenablog.jp/entry/2019/05/05/033730 https://mt-soft.sakura.ne.jp/kyozai/excel_vba/310_vba_chu/54_mazemake/index.htm https://papasensei365.com/excel-nonvba-3d-maze/ ---- ↑ ニックネーム送信されませんでした。 （みみ） 2022/10/22(土) 15:04:34 ---- 皆さま ありがとうございます。いろいろと探していたら以下のサイトに辿り着きまた https://www.worksheetworks.com/english/alphabet/alphabet-maze.html これがわたしが考えていたものなのですが、ご教示いただいたサイトを見てもわたしにはこれを改造して上記サイトの内容に改造できるだけの知識がありません。諦めた方が良さそうです。 （羽田空港） 2022/10/22(土) 16:35:26 ---- 投稿しましたが、見直しますので、いったん取り下げます。 他の方の投稿を参考にしてください。22:26 （γ） 2022/10/25(火) 19:43:17 ---- ヒントでも参考コードでもありません。 15年ほど前に暇つぶしに作ったコードです。 アクティブセルを基点に指定の数だけセルを移動します。 次進む方向は乱数任せです。 一度通ったセルは再度通ることができません。 袋小路になったらそこでお手上げです。 袋小路にならないで指定数セルを移動出来たら「完了」 です。 完了まで行ったら出来た図が迷路に見えなくもないです・・・。 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からZ迄が並ぶとして A〜Zまで来たら、最初の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 ---- かって作ったことがあったので、懐かしく拝見しました。 最終保存が2001年でしたので、コードを紐解く元気もありませんが、参考までに 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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202210/20221022080323.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97012 documents and 608132 words.
訪問者：