クイズ大陸



履歴 検索 最新 出題

No. 3≫ No.4 ≫No. 5
?ほにょこ 2022/12/16 17:32
<tt>私が昔Excel VBAで作成した倉庫番のプログラムを紹介します。
Excel 2016で動作確認しました。
マクロ有効ブックを作成し、VBAの画面を表示(ALT+F11)。
左上に表示されるシート一覧から一つを選んでダブルクリックします。
(Sheet3としておきます)
次のコードを貼り付けて閉じます。

☆☆☆↓ここから
Const YY = 2, XX = 12
Private Sub Worksheet_Activate()
Dim DATA(10) As String
KOSU = 0
CHARA = UCase(Cells(YY, XX))
If CHARA <> "E" Then
DATA(0) = "□□□□□□□□□/"
DATA(1) = "□□□//□□□□/"
DATA(2) = "□///○△//□/"
DATA(3) = "□/□//□○/□/"
DATA(4) = "□/※/※□//□/"
DATA(5) = "□□□□□□□□□/"
DATA(6) = "//////////"
DATA(7) = "//////////"
DATA(8) = "//////////"
DATA(9) = "//////////"
Cells.ClearContents
CX = 0
For WY = 1 To 10
For WX = 1 To 10
CHARA = Mid(DATA(WY - 1), WX, 1)
CX = InStr("△▲○●□※", CHARA)
Select Case CX
Case 0
CHARA = " "
Case Is <= 2
Cells(YY + 2, XX) = WY: Cells(YY + 2, XX + 1) = WX
Case 3
KOSU = KOSU + 1
End Select
Cells(WY, WX) = CHARA
Next WX
Next WY
Cells(YY - 1, XX) = "↑"
Cells(YY, XX - 1) = "←"
Cells(YY + 1, XX) = "↓"
Cells(YY, XX + 1) = "→"
Cells(YY + 3, XX) = KOSU
Columns("A:M").EntireColumn.AutoFit
Cells(YY, XX).Select
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim OKIBA(3) As Integer
CHARA = UCase(Cells(YY, XX))
If CHARA <> "E" Then
dy = Target.Row - YY: dx = Target.Column - XX
If Abs(dy) + Abs(dx) = 1 Then
CY = Cells(YY + 2, XX): CX = Cells(YY + 2, XX + 1)
NY = CY + dy: NX = CX + dx
NY2 = NY + dy: NX2 = NX + dx
CELL1 = Cells(NY, NX)
If Cells(CY, CX) = "▲" Then OKIBA(0) = 1
If CELL1 = "●" Or CELL1 = "※" Then OKIBA(1) = 1
If InStr("□○●", CELL1) = 0 Then
Cells(NY, NX) = Mid("△▲", OKIBA(1) + 1, 1)
Cells(CY, CX) = Mid(" ※", OKIBA(0) + 1, 1)
Cells(YY + 2, XX) = NY: Cells(YY + 2, XX + 1) = NX
End If
If CELL1 = "○" Or CELL1 = "●" Then
CELL2 = Cells(NY2, NX2)
If CELL2 = "※" Then OKIBA(2) = 1
If InStr("□○●", CELL2) = 0 Then
Cells(NY2, NX2) = Mid("○●", OKIBA(2) + 1, 1)
Cells(NY, NX) = Mid("△▲", OKIBA(1) + 1, 1)
Cells(CY, CX) = Mid(" ※", OKIBA(0) + 1, 1)
Cells(YY + 2, XX) = NY: Cells(YY + 2, XX + 1) = NX
Cells(YY + 3, XX) = Cells(YY + 3, XX) + OKIBA(1) - OKIBA(2)
If Cells(YY + 3, XX) = 0 Then Cells(YY, XX) = "E"
End If
End If
End If
Cells(YY, XX).Select
End If
End Sub
☆☆☆↑ここまで

シートを切り替えてSheet3を表示すると倉庫番が遊べるようになるはずです。
□は壁、△はプレイヤー、○は荷物です。
荷物置き場は※。
矢印キーで△が動きます。
シート内の「→」「↓」「←」「↑」をマウスでクリックしても動きます。
自分や荷物が※と重なった場合は▲、●となります。
すべての荷物を正しい場所に置くと「E」が表示されてゲームは止まります。
「E」を手入力しても止まります。
「E」でない状態でシートを切り替えると最初の状態に戻ります。

DATA(0)〜DATA(9)に盤面の初期状態をセットしています。
ここを書き変えれば他の盤面も遊べます。</tt>
返信 編集
感服・目からウロコ?千夜一夜
(**) いやあ!! 素晴らしすぎます!!! (**)

ありがとうございます (^_^)