迷路にネコが挑戦したら、どうなるかな…

公開日：2022-06-26　最終更新日：2022-07-26

迷路にネコが挑戦したら、どうなるかな…

ツイッターで迷路を解くVBAが流行っていたので、それならと言う事で私も参加してみることに・・・

迷路の解き方は定番の方法がありますが、それらはツイッターの他の人に任せるとして、ちょっと独自の挑戦をしてみました。

※これはジョークソフトです。

続編もあります。
迷路ネコが影分身の術を体得したら…

ツイッターで迷路を解くVBAが流行っていたので、ネコを迷路に挑戦させてみた… 迷路にネコが挑戦したら、どうなるかな… さすがに壁登りで迷路クリアは、、、ということで、ちゃんと迷路を攻略するようにネコを調教しました。ツイート「壁登りは反則だろ」という厳しいご意見があったりなかったり… まうにゃんは厳しい躾けの末、

迷路が流行っているので私も参加してみよかと。
迷路作成は、としじさん
@toshi81350036
https://note.com/toshi81350036/n/n3a395539474e

こちらをお借りしました。
さて、どんな迷路探索を作りましょうかね・・・

https://twitter.com/yamaoka_ss/status/1540682038935953409

迷路に入るのは、私の友人の猫です。
名前は「まうにゃん」
まだ知能はほとんどない。
さて、どんな旅路になりますか・・・
さっそくスタートしてもらいましょう。
・・・
こらー、寝るなー💢起きろー💢

ネコなので、たまに寝るのは仕方ないけど、なるべく我慢するようにと言い聞かせました。（聞いてるかは分からんけど）
あと、ネコなんだから、もう少し早く走ろうよと。
いつまでたってもゴール出来ないし。
これで、少しは進んでくれると良いのですが・・・
※セル選択しない方が見やすいかな

まうにゃんも、何度か迷路に挑戦していたので、少しは賢くなってきたでしょうか。
楽しみです。
・・・
おっと、それは迷路では禁断の壁登り・・・
まあ、ネコだから、許されるのか・・・

かくして、壁登りの反則技まで繰り出したまうにゃんは無事ゴールにたどり着けたのでしょうか。
・・・
ゴールの瞬間をどうぞ。

ネコの絵文字

前提として、ネコの絵文字を「文字」シートに入れておきます。

UNICODEのこのような文字は、VBAで扱いづらいのでシートに置くことにしました。

VBAソースコード

クラスモジュール：clsMaunyan


  
    
      Option Explicit


      Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


      Private sにゃん1 As String

      Private sにゃん2 As String


      Public 現在位置 As Range

      Public 前回位置 As Range

      Public 迷路 As Range


      Private is壁登り As Boolean


      Private Enum e進行

      　　スタート = 0

      　　進路 = 1

      　　戻る = 2

      　　壁だ = 3

      　　ゴール = 9

      　　範囲外 = 99

      End Enum


      Public Sub 位置について(ByVal rng As Range)

      　　Set 前回位置 = rng

      　　Set 現在位置 = rng

      　　Call setにゃん1(rng)

      End Sub


      Public Function 進め() As Boolean

      　　進め = False

      　　If 現在位置 Is Nothing Or 前回位置 Is Nothing Or 迷路 Is Nothing Then

      　　　 MsgBox "にゃあ"

      　　　 Exit Function

      　　End If

      　　

      　　Dim coll As New Collection

      　　Dim r As Long, i As Long, k As Long, ix1 As Long, ix2 As Long

      　　Dim 方向(1 To 4) As Variant

      　　

      　　方向(1) = 進行判定(現在位置.Offset(-1, 0))

      　　方向(2) = 進行判定(現在位置.Offset(0, 1))

      　　方向(3) = 進行判定(現在位置.Offset(0, -1))

      　　方向(4) = 進行判定(現在位置.Offset(1, 0))

      　　

      　　For i = 1 To 4

      　　　　If 方向(i)(2) = e進行.ゴール Then

      　　　　　　For ix2 = 0 To 4

      　　　　　　　　Call setComment(現在位置, "ここはゴールじゃないのか" & String(ix2, "・"))

      　　　　　　Next

      　　　　　　is壁登り = False

      　　　　　　Call setにゃん1(方向(i)(1))

      　　　　　　Call setComment(現在位置, "やったー" & vbLf & "ゴールだ" & vbLf & "チュールちょうだい！！！")

      　　　　　　進め = True

      　　　　　　Exit Function

      　　　　End If

      　　Next

      　　

      　　r = getRandom(1, 4)

      　　i = r

      　　Do Until 方向(i)(2) = IIf(is壁登り, e進行.壁だ, e進行.進路)

      　　　　If 方向(i)(2) = e進行.戻る Then k = i

      　　　　i = i + 1

      　　　　If i > 4 Then i = 1

      　　　　If i = r Then

      　　　　　　If getRandom(1, 10) = 1 Then

      　　　　　　　　For ix1 = 1 To 4

      　　　　　　　　　　If 方向(ix1)(2) = IIf(is壁登り, e進行.進路, e進行.壁だ) Then

      　　　　　　　　　　　　Sleep 500

      　　　　　　　　　　　　　　For ix2 = 0 To 4

      　　　　　　　　　　　　　　　　Call setComment(現在位置, IIf(is壁登り, "この辺で降りようかな" & String(ix2, "・"), _

      　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　 "この壁は登れそうだな" & String(ix2, "・")))

      　　　　　　　　　　　　　　Next

      　　　　　　　　　　　　　　現在位置.ClearComments

      　　　　　　　　　　　　is壁登り = Not is壁登り

      　　　　　　　　　　　　k = ix1

      　　　　　　　　　　　　Exit For

      　　　　　　　　　　End If

      　　　　　　　　Next

      　　　　　　End If

      　　　　　　i = k: Exit Do

      　　　　End If

      　　Loop

      　　

      　　Call setにゃん1(方向(i)(1))

      　　

      　　If getRandom(1, 300) = 1 Then

      　　　　For ix1 = 1 To 3

      　　　　　　For ix2 = 0 To 4

      　　　　　　　　Call setComment(現在位置, "z" & String(ix2, "Z"))

      　　　　　　Next

      　　　　Next

      　　　　現在位置.ClearComments

      　　End If

      End Function


      Private Function 進行判定(ByVal rng As Range) As Variant

      　　Dim rtnAry(1 To 2)

      　　Set rtnAry(1) = rng

      　　

      　　If Intersect(rng, 迷路) Is Nothing Then

      　　　　rtnAry(2) = e進行.範囲外

      　　　　GoTo Exit01

      　　End If

      　　

      　　If rng.Address = 前回位置.Address Then

      　　　　rtnAry(2) = e進行.戻る

      　　　　GoTo Exit01

      　　End If

      　　

      　　Select Case rng.Value

      　　　　Case "Start": rtnAry(2) = e進行.スタート

      　　　　Case "Goal": rtnAry(2) = e進行.ゴール

      　　　　Case ""

      　　　　　　If rng.Interior.Color = vbBlack Then

      　　　　　　　　rtnAry(2) = e進行.壁だ

      　　　　　　Else

      　　　　　　　　rtnAry(2) = e進行.進路

      　　　　　　End If

      　　End Select

      　　

      Exit01:

      　　進行判定 = rtnAry

      End Function


      Private Sub setにゃん1(ByVal rng As Range)

      　　Set 前回位置 = 現在位置

      　　前回位置.Value = ""

      　　前回位置.ClearComments

      　　Set 現在位置 = rng

      　　If is壁登り Then

      　　　　現在位置.Value = sにゃん2

      　　Else

      　　　　現在位置.Value = sにゃん1

      　　End If

      　　現在位置.Font.Color = vbRed

      　　Sleep 100

      End Sub


      Private Sub Class_Initialize()

      　　sにゃん1 = Worksheets("文字").Range("A1")

      　　sにゃん2 = Worksheets("文字").Range("A2")

      　　is壁登り = False

      End Sub


      Function getRandom(ByVal aMin As Long, aMax As Long) As Long

      　　Randomize

      　　getRandom = Int((aMax - aMin + 1) * Rnd + aMin)

      End Function


      Private Sub setComment(ByVal rng As Range, sComment As String)

      　　With rng

      　　　　.ClearComments

      　　　　.AddComment sComment

      　　　　.Comment.Shape.TextFrame.Characters.Font.Size = 16

      　　　　.Comment.Shape.TextFrame.AutoSize = True

      　　　　.Comment.Visible = True

      　　　　DoEvents

      　　　　Sleep 500

      　　End With

      End Sub

標準モジュール


  
    
      Sub main()

　　Dim cls As New clsMaunyan

　　With Range("D2:AR38")

　　　　.ClearContents

　　　　.ClearComments

　　　　.Range("A2").Value = "Start"

　　　　.Range("A2").Font.ColorIndex = xlAutomatic

　　　　.Item(.Count).Offset(-1).Value = "Goal"

　　　　.Item(.Count).Offset(-1).Font.ColorIndex = xlAutomatic

　　　　Set cls.迷路 = .Cells

　　End With

　　Application.Wait Now() + TimeSerial(0, 0, 1)

　　Call cls.位置について(cls.迷路.Range("A2"))

　　Application.Wait Now() + TimeSerial(0, 0, 1)

　　Do

　　　　If cls.進め Then Exit Do

　　　　DoEvents

　　Loop

End Sub

同じテーマ「ツイッター出題回答」の記事

ツイッターで出されたVBAのお題（悪魔のCSV）をやってみた
 「VBAで導関数を求めよ」ツイッターのお題をやってみた
 ツイッターのお題「君の名は？」
ツイッターのお題「CSV編集」
アルファベットの26進（ツイッターお題）
ナンバープレート数字遊び：ツイッターお題
 サロゲートペアに対応した自作関数（Len,Left,Mid,Right）
迷路にネコが挑戦したら、どうなるかな…
迷路ネコが影分身の術を体得したら…
VBAで漢数字を算用数字に変換

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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.繰り返し処理（For Next)｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.メッセージボックス(MsgBox関数)｜VBA入門
8.セルのクリア（Clear,ClearContents）｜VBA入門
9.ブック・シートの選択（Select,Activate）｜VBA入門
10.条件分岐（Select Case）｜VBA入門

ホーム
エクセル全般
ツイッター出題回答
迷路にネコが挑戦したら、どうなるかな…

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

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

ツイッター出題回答
迷路にネコが挑戦したら、どうなるかな…