迷路にネコが挑戦したら、どうなるかな…
ツイッターで迷路を解くVBAが流行っていたので、それならと言う事で私も参加してみることに・・・
迷路ネコが影分身の術を体得したら…
ツイート
迷路作成は、としじさん
@toshi81350036
https://note.com/toshi81350036/n/n3a395539474e
さて、どんな迷路探索を作りましょうかね・・・

https://twitter.com/yamaoka_ss/status/1540682038935953409
名前は「まうにゃん」
まだ知能はほとんどない。
さて、どんな旅路になりますか・・・
さっそくスタートしてもらいましょう。
・・・
こらー、寝るなー💢起きろー💢

あと、ネコなんだから、もう少し早く走ろうよと。
いつまでたってもゴール出来ないし。
これで、少しは進んでくれると良いのですが・・・
※セル選択しない方が見やすいかな

楽しみです。
・・・
おっと、それは迷路では禁断の壁登り・・・
まあ、ネコだから、許されるのか・・・

・・・
ゴールの瞬間をどうぞ。

ネコの絵文字

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 ・・・新着記事一覧を見る
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コードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。