VBAで迷路を作る

としじ＠栃木都知事 🚗³₃さんはTwitterを使っています: 「いつでも迷路で遊べるようになりました https://t.co/nA5F4DLH4a」 / Twitter

（このコードビミョー間違ってます）

Private Sub Wait()
   Application.Wait [now()+"0:00:00.01"]
   DoEvents
End Sub

Sub 棒倒し法で迷路作成()
   
   Const START_ROW = 2, START_COL = 2, GAME_WIDTH = 20 * 2 + 1, GAME_HEIGHT = 18 * 2 + 1
   Dim i, j, n
   
   Cells.Clear
   
   ' 外枠を描画 '
   Cells(START_ROW + 0, START_COL + 0).Resize(GAME_HEIGHT - 0, GAME_WIDTH - 0).Interior.Color = vbBlack
   Cells(START_ROW + 1, START_COL + 1).Resize(GAME_HEIGHT - 2, GAME_WIDTH - 2).Interior.Color = xlNone
   
   ' スタートとゴールを描画 '
   Cells(START_ROW + 1, START_COL + 0).Interior.Color = xlNone
   Cells(START_ROW + GAME_HEIGHT - 2, START_COL + GAME_WIDTH - 1).Interior.Color = xlNone
   
   Randomize
   
   ' 1段目は4方向どこに倒れてもいい '
   i = START_ROW + 2
   For j = START_COL + 2 To GAME_WIDTH - START_COL + 1 Step 2
      Cells(i, j).Interior.Color = vbBlack
      ' 既に倒れているところはダメ '
      Do
         n = Rnd * 4
         Select Case n
            Case Is < 1: If Cells(i, j).Offset(, 1).Interior.Color <> vbBlack Then Exit Do
            Case Is < 2: If Cells(i, j).Offset(, -1).Interior.Color <> vbBlack Then Exit Do
            Case Is < 3: If Cells(i, j).Offset(1).Interior.Color <> vbBlack Then Exit Do
            Case Is < 4: If Cells(i, j).Offset(-1).Interior.Color <> vbBlack Then Exit Do
         End Select
      Loop
      ' 帽を倒す '
      Select Case n
         Case Is < 1: Cells(i, j).Offset(, 1).Interior.Color = vbBlack
         Case Is < 2: Cells(i, j).Offset(, -1).Interior.Color = vbBlack
         Case Is < 3: Cells(i, j).Offset(1).Interior.Color = vbBlack
         Case Is < 4: Cells(i, j).Offset(-1).Interior.Color = vbBlack
      End Select
      Wait
   Next
   
   ' 2段目以降は上に倒れてはいけない '
   For i = START_ROW + 4 To GAME_HEIGHT - START_ROW + 1 Step 2
      For j = START_COL + 2 To GAME_WIDTH - START_COL + 1 Step 2
         Cells(i, j).Interior.Color = vbBlack
         ' 既に倒れているところはダメ '
         Do
            n = Rnd * 3
            Select Case n
               Case Is < 1: If Cells(i, j).Offset(, 1).Interior.Color <> vbBlack Then Exit Do
               Case Is < 2: If Cells(i, j).Offset(, -1).Interior.Color <> vbBlack Then Exit Do
               Case Is < 3: If Cells(i, j).Offset(1).Interior.Color <> vbBlack Then Exit Do
            End Select
         Loop
         ' 帽を倒す '
         Select Case n
            Case Is < 1: Cells(i, j).Offset(, 1).Interior.Color = vbBlack
            Case Is < 2: Cells(i, j).Offset(, -1).Interior.Color = vbBlack
            Case Is < 3: Cells(i, j).Offset(1).Interior.Color = vbBlack
         End Select
         Wait
      Next
   Next
   
End Sub

6月26日(日)　間違い修正

Private Sub Wait()
  Application.Wait [now()+"0:00:00.01"]
  DoEvents
End Sub

Sub 棒倒し法で迷路作成()
  
  Const START_ROW = 2, START_COL = 2, GAME_WIDTH = 20 * 2 + 1, GAME_HEIGHT = 18 * 2 + 1
  Dim i, j, n
  
  Cells.Clear
  
  ' 外枠を描画 '
  Cells(START_ROW + 0, START_COL + 0).Resize(GAME_HEIGHT - 0, GAME_WIDTH - 0).Interior.Color = vbBlack
  Cells(START_ROW + 1, START_COL + 1).Resize(GAME_HEIGHT - 2, GAME_WIDTH - 2).Interior.Color = xlNone
  
  ' スタートとゴールを描画 '
  Cells(START_ROW + 1, START_COL + 0).Interior.Color = xlNone
  Cells(START_ROW + GAME_HEIGHT - 2, START_COL + GAME_WIDTH - 1).Interior.Color = xlNone
  
  Randomize
  
  ' 1段目は4方向どこに倒れてもいい '
  i = START_ROW + 2
  For j = START_COL + 2 To START_COL + GAME_WIDTH - 3 Step 2
     Cells(i, j).Interior.Color = vbBlack
     ' 既に倒れているところはダメ '
     Do
        n = Rnd * 4
        Select Case n
           Case Is < 1: If Cells(i, j).Offset(, 1).Interior.Color <> vbBlack Then Exit Do
           Case Is < 2: If Cells(i, j).Offset(, -1).Interior.Color <> vbBlack Then Exit Do
           Case Is < 3: If Cells(i, j).Offset(1).Interior.Color <> vbBlack Then Exit Do
           Case Is < 4: If Cells(i, j).Offset(-1).Interior.Color <> vbBlack Then Exit Do
        End Select
     Loop
     ' 帽を倒す '
     Select Case n
        Case Is < 1: Cells(i, j).Offset(, 1).Interior.Color = vbBlack
        Case Is < 2: Cells(i, j).Offset(, -1).Interior.Color = vbBlack
        Case Is < 3: Cells(i, j).Offset(1).Interior.Color = vbBlack
        Case Is < 4: Cells(i, j).Offset(-1).Interior.Color = vbBlack
     End Select
     Wait
  Next
  
  ' 2段目以降は上に倒れてはいけない '
  For i = START_ROW + 4 To START_ROW + GAME_HEIGHT - 3 Step 2
     For j = START_COL + 2 To START_COL + GAME_WIDTH - 3 Step 2
        Cells(i, j).Interior.Color = vbBlack
        ' 既に倒れているところはダメ '
        Do
           n = Rnd * 3
           Select Case n
              Case Is < 1: If Cells(i, j).Offset(, 1).Interior.Color <> vbBlack Then Exit Do
              Case Is < 2: If Cells(i, j).Offset(, -1).Interior.Color <> vbBlack Then Exit Do
              Case Is < 3: If Cells(i, j).Offset(1).Interior.Color <> vbBlack Then Exit Do
           End Select
        Loop
        ' 帽を倒す '
        Select Case n
           Case Is < 1: Cells(i, j).Offset(, 1).Interior.Color = vbBlack
           Case Is < 2: Cells(i, j).Offset(, -1).Interior.Color = vbBlack
           Case Is < 3: Cells(i, j).Offset(1).Interior.Color = vbBlack
        End Select
        Wait
     Next
  Next
  
End Sub