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

ExcelマクロVBAとエクセル関数についての私的雑感
公開日:2022-06-26 最終更新日:2022-07-26

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


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


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

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

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


ツイート

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

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

Excel VBA 迷路
https://twitter.com/yamaoka_ss/status/1540682038935953409


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

Excel VBA 迷路


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

Excel VBA 迷路


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

Excel VBA 迷路


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

Excel VBA 迷路


ネコの絵文字

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

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で漢数字を算用数字に変換


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

ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
累計を求める数式あれこれ|エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE|エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。|エクセル雑感(2023-12-28)
VBAでクリップボードへ文字列を送信・取得する3つの方法|VBA技術解説(2023-12-07)
難しい数式とは何か?|エクセル雑感(2023-12-07)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.変数宣言のDimとデータ型|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.並べ替え(Sort)|VBA入門
8.条件分岐(IF)|VBA入門
9.セルのクリア(Clear,ClearContents)|VBA入門
10.マクロとは?VBAとは?VBAでできること|VBA入門




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


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



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