ツイッター出題回答
迷路ネコが影分身の術を体得したら…

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

迷路ネコが影分身の術を体得したら…


ツイッターで迷路を解くVBAが流行っていたので、ネコを迷路に挑戦させてみた・・・

迷路にネコが挑戦したら、どうなるかな…
ツイッターで迷路を解くVBAが流行っていたので、それならと言う事で私も参加してみることに… 迷路の解き方は定番の方法がありますが、それらはツイッターの他の人に任せるとして、ちょっと独自の挑戦をしてみました。※これはジョークソフトです。続編もあります。


さすがに壁登りで迷路クリアは、、、
ということで、ちゃんと迷路を攻略するようにネコを調教しました。



ツイート

「壁登りは反則だろ」という厳しいご意見があったりなかったり・・・
まうにゃんは厳しい躾けの末、居眠りも壁登りもせずに進むようになった。
さらに必死の修行を重ねて、ついに「影分身」の術を体得した。
突き当りに行った分身は「ボン」と消える。
ゴールに着いた分身が道順を知らせてくれる。

Excel VBA 迷路


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


ネコの絵文字

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

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

VBAソースコード

お遊びソフトなので、VBAコードはあまりこだわらずに書きなぐったままになっています。
VBAコードの書き方等も、あまり推奨できるような書き方にはなっていません。
Public変数を多用したり、クラス内のMe.の使い方等、ざっと書いたままになっています。
また、変数名も日本語でそのまま書いていたりしています。
以上の点はご承知おきください。

クラスモジュール:clsMaunyan

Option Explicit

Public 状態 As e状態
Public 現在位置 As Range
Public 前回位置 As Range
Public 迷路 As Range
Public routeRange As Range

Public Sub 位置について(ByVal rng As Range)
  Set 前回位置 = rng
  Set 現在位置 = rng
  Call setにゃん1(rng)
  Set routeRange = rng
End Sub

Public Function 進め() As Boolean
  進め = False
  
  Select Case 状態
    Case e状態.突き当り
      現在位置.Value = ""
      状態 = e状態.終了
      Exit Function
    Case e状態.終了
      Exit Function
  End Select
  
  If 現在位置 Is Nothing Or 前回位置 Is Nothing Or 迷路 Is Nothing Then
    MsgBox "にゃあ"
    Exit Function
  End If
  
  Dim 方向(1 To 4) As Variant
  方向(1) = 進行判定(現在位置.Offset(-1, 0))
  方向(2) = 進行判定(現在位置.Offset(0, 1))
  方向(3) = 進行判定(現在位置.Offset(0, -1))
  方向(4) = 進行判定(現在位置.Offset(1, 0))
  
  Dim i As Long
  For i = 1 To 4
    If 方向(i)(2) = e進行.ゴール Then
      Call setにゃん1(方向(i)(1))
      Sleep 500
      routeRange.Value = sにゃん1
      進め = True
      Exit Function
    End If
  Next
  
  Dim iNext As Long
  For i = 1 To 4
    If 方向(i)(2) = e進行.進路 Then
      If iNext = 0 Then
        iNext = i
      Else
        colNyan.Add CloneMe(現在位置, 方向(i)(1))
      End If
    End If
  Next
  If iNext = 0 Then
    状態 = 突き当り
    現在位置.Value = sにゃん2
    Exit Function
  End If
  
  Call setにゃん1(方向(iNext)(1))
  Set routeRange = Union(routeRange, 方向(iNext)(1))
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 = ""
  Set 現在位置 = rng
  現在位置.Value = sにゃん1
  現在位置.Font.Color = vbRed
End Sub

Private Sub Class_Initialize()
  状態 = e状態.進行中
End Sub

Private Function CloneMe(ByVal a現セル As Range, ByVal a次セル As Range) As clsMaunyan
  Set CloneMe = New clsMaunyan
  With CloneMe
    Set .迷路 = Me.迷路
    .位置について a次セル
    Set .前回位置 = a現セル
    Set .routeRange = Union(routeRange, a次セル)
  End With
End Function


標準モジュール

Option Explicit

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

Public sにゃん1 As String
Public sにゃん2 As String

Public colNyan As Collection

Public Enum e状態
  進行中 = 0
  突き当り = 1
  終了 = 2
  ゴール = 9
End Enum

Public Enum e進行
  スタート = 0
  進路 = 1
  戻る = 2
  壁だ = 3
  ゴール = 9
  範囲外 = 99
End Enum

Sub main()
  sにゃん1 = Worksheets("文字").Range("A1")
  sにゃん2 = Worksheets("文字").Range("A2")
  
  Set colNyan = New Collection
  Dim cls As New clsMaunyan
  
  With Range("D2:AR38")
    .ClearContents
    .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
  Sleep 500
  Call cls.位置について(cls.迷路.Cells(2, 2))
  colNyan.Add cls, cls.現在位置.Address
  
  Dim v
  Do
    For i = colNyan.Count To 1 Step -1
      Set v = colNyan(i)
      If v.状態 = e状態.終了 Then
        Set v = Nothing
        colNyan.Remove i
      Else
        If v.進め Then Exit Do
      End If
    Next
    DoEvents
    Sleep 50
  Loop
End Sub




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

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


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

8桁数値が日付として不適切なら赤にする条件付き書式|ツイッター出題回答 (2022-08-10)
年月に対して有効な日だけの入力規則のリスト作成|ツイッター出題回答 (2022-08-10)
VBA穴埋め問題「On Error GoToの挙動」|ツイッター出題回答 (2022-08-09)
シート内の全テーブルを1つに統合|ツイッター出題回答 (2022-08-01)
VBAで漢数字を算用数字に変換|ツイッター出題回答 (2022-07-12)
成績表(ネ申エクセル)を別表に集計|ツイッター出題回答 (2022-07-09)
m/d/yyyy形式文字列を日付シリアル値に変換|ツイッター出題回答 (2022-07-07)
ジャグ配列から順列を作成する|ツイッター出題回答 (2022-07-05)
15桁を超える数値の足し算|ツイッター出題回答 (2022-07-01)
抜けている数値を探せ|ツイッター出題回答 (2022-07-01)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.マクロって何?VBAって何?|VBA入門
7.Excelショートカットキー一覧|Excelリファレンス
8.並べ替え(Sort)|VBA入門
9.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
10.エクセルVBAでのシート指定方法|VBA技術解説




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


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



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