anonymous Twitter #VBA100本ノック 迷宮編 Ver1.00
No License VBA
2020年12月31日
Copy Clone
Option Explicit

Sub Meikyuu()

    ' #VBA100本ノック 迷宮編

    Dim x       As Long, y As Long, ny As Long, nx As Long ' セル位置座標用
    Dim Bx      As Long, By As Long, Bnx As Long, Bny As Long   ' 5×5ブロック単位範囲用
    Dim ForY    As Long, ForX As Long, ForXS As Long, ForXE As Long, xStep As Long
    Dim i       As Long, iss As Long, ie As Long, iStep As Long
    Dim j       As Long, js As Long, je As Long, jStep As Long
    Dim Kyori   As Double, stKyori As Double               ' 直線距離計算用
    Dim Flg     As Boolean                                 ' 最短距離フラグ
    Dim Arr     As Variant                                 ' セル値ストック用配列
    
    Range("A1:O15").ClearContents: Range("A1").Select      ' シートクリア
    x = 1: y = 1                ' スタート位置セット
    
    ' 5×5のブロック単位でサーチ
    For ForY = 1 To 11 Step 5
        ' 横位置は左右スタート位置が交互にする設定
        If ForY = 6 Then ForXS = 11: ForXE = 1: xStep = -5 Else ForXS = 1: ForXE = 11: xStep = 5
        ' ブロック単位サーチ
        For ForX = ForXS To ForXE Step xStep
            ' ブロック内左右サーチはプロック左右進行方向に合わせる
            If ForY = 6 Then iss = 4: ie = 0: iStep = -1 Else iss = 0: ie = 4: iStep = 1
            For Bx = iss To ie Step iStep
                ' ブロック内上下は前回通過点に近い方からスタートし、交互に上下
                If x Mod 5 = 0 Or x Mod 5 = 4 Then js = 4: je = 0: jStep = -1 Else js = 0: je = 4: jStep = 1
                For By = js To je Step jStep
                    If Cells(ForY + By, ForX + Bx).Interior.Color = vbYellow Then
                        Call Marking(y, x, ForY + By, ForX + Bx)    ' ルートマーキング処理へ
                        y = ForY + By: x = ForX + Bx
                    End If
                Next
            Next
        Next
    Next
    
    Call Marking(y, x, 15, 15)    ' 最終黄色地点から終点まで
    
End Sub

Sub Marking(y As Long, x As Long, ny As Long, nx As Long)

    Dim stPos As Long, i As Long, sStep As Long
    Dim Flg     As Boolean  ' 通過で出来ずフラグ
    Dim stArr   As Variant  ' セル値ストック用配列
    
    stArr = Range("A1:O15").Value ' 最初のセル状態ストック
    
    ' 【地点間の通過済でないルート探索(縦位置スタートから試み、駄目なら次に横位置スタート)】
    Flg = True
    ' 縦 → 横 探索
    ' 最初に縦位置探索(既に通過済と交わればフラグOFF)
    If y <= ny Then sStep = 1 Else sStep = -1
    Cells(y, x).Value = "" ' スタート位置クリア
    For i = y To ny Step sStep
        If Cells(i, x).Value <> "" Then Flg = False
        Cells(i, x).Value = "●"
    Next
    
    ' 次に横位置探索(既に通過済と交わればフラグOFF)
    If x <= nx Then sStep = 1 Else sStep = -1
    Cells(ny, x).Value = "" ' スタート位置クリア
    For i = x To nx Step sStep
        If Cells(ny, i).Value <> "" Then Flg = False
        Cells(ny, i).Value = "●"
    Next
    
    ' 既に通過済みと交差してなければ戻る
    If Flg Then Exit Sub
    
    Range("A1:O15") = stArr ' 前の状態をクリア
    Flg = True
    ' 横 → 縦 探索
    ' 最初に横位置探索(既に通過済と交わればフラグOFF)
    If x <= nx Then sStep = 1 Else sStep = -1
    Cells(i, y).Value = "" ' スタート位置クリア
    For i = x To nx Step sStep
        If Cells(y, i).Value <> "" Then Flg = False
        Cells(y, i).Value = "●"
    Next
    ' 次に縦位置探索(既に通過済と交わればフラグOFF)
    If y <= ny Then sStep = 1 Else sStep = -1
    Cells(y, nx).Value = ""     ' スタート位置クリア
    For i = y To ny Step sStep  ' 次に横位置
        If Cells(i, nx).Value <> "" Then Flg = False
        Cells(i, nx).Value = "●"
    Next

End Sub
Option Explicit

Sub Meikyuu()

    ' #VBA100本ノック 迷宮編

    Dim x       As Long, y As Long, ny As Long, nx As Long ' セル位置座標用
    Dim Bx      As Long, By As Long, Bnx As Long, Bny As Long   ' 5×5ブロック単位範囲用
    Dim ForY    As Long, ForX As Long, ForXS As Long, ForXE As Long, xStep As Long
    Dim i       As Long, iss As Long, ie As Long, iStep As Long
    Dim j       As Long, js As Long, je As Long, jStep As Long
    Dim Kyori   As Double, stKyori As Double               ' 直線距離計算用
    Dim Flg     As Boolean                                 ' 最短距離フラグ
    Dim Arr     As Variant                                 ' セル値ストック用配列
    
    Range("A1:O15").ClearContents: Range("A1").Select      ' シートクリア
    x = 1: y = 1                ' スタート位置セット
    
    ' 5×5のブロック単位でサーチ
    For ForY = 1 To 11 Step 5
        ' 横位置は左右スタート位置が交互にする設定
        If ForY = 6 Then ForXS = 11: ForXE = 1: xStep = -5 Else ForXS = 1: ForXE = 11: xStep = 5
        ' ブロック単位サーチ
        For ForX = ForXS To ForXE Step xStep
            ' ブロック内左右サーチはプロック左右進行方向に合わせる
            If ForY = 6 Then iss = 4: ie = 0: iStep = -1 Else iss = 0: ie = 4: iStep = 1
            For Bx = iss To ie Step iStep
                ' ブロック内上下は前回通過点に近い方からスタートし、交互に上下
                If x Mod 5 = 0 Or x Mod 5 = 4 Then js = 4: je = 0: jStep = -1 Else js = 0: je = 4: jStep = 1
                For By = js To je Step jStep
                    If Cells(ForY + By, ForX + Bx).Interior.Color = vbYellow Then
                        Call Marking(y, x, ForY + By, ForX + Bx)    ' ルートマーキング処理へ
                        y = ForY + By: x = ForX + Bx
                    End If
                Next
            Next
        Next
    Next
    
    Call Marking(y, x, 15, 15)    ' 最終黄色地点から終点まで
    
End Sub

Sub Marking(y As Long, x As Long, ny As Long, nx As Long)

    Dim stPos As Long, i As Long, sStep As Long
    Dim Flg     As Boolean  ' 通過で出来ずフラグ
    Dim stArr   As Variant  ' セル値ストック用配列
    
    stArr = Range("A1:O15").Value ' 最初のセル状態ストック
    
    ' 【地点間の通過済でないルート探索(縦位置スタートから試み、駄目なら次に横位置スタート)】
    Flg = True
    ' 縦 → 横 探索
    ' 最初に縦位置探索(既に通過済と交わればフラグOFF)
    If y <= ny Then sStep = 1 Else sStep = -1
    Cells(y, x).Value = "" ' スタート位置クリア
    For i = y To ny Step sStep
        If Cells(i, x).Value <> "" Then Flg = False
        Cells(i, x).Value = "●"
    Next
    
    ' 次に横位置探索(既に通過済と交わればフラグOFF)
    If x <= nx Then sStep = 1 Else sStep = -1
    Cells(ny, x).Value = "" ' スタート位置クリア
    For i = x To nx Step sStep
        If Cells(ny, i).Value <> "" Then Flg = False
        Cells(ny, i).Value = "●"
    Next
    
    ' 既に通過済みと交差してなければ戻る
    If Flg Then Exit Sub
    
    Range("A1:O15") = stArr ' 前の状態をクリア
    Flg = True
    ' 横 → 縦 探索
    ' 最初に横位置探索(既に通過済と交わればフラグOFF)
    If x <= nx Then sStep = 1 Else sStep = -1
    Cells(i, y).Value = "" ' スタート位置クリア
    For i = x To nx Step sStep
        If Cells(y, i).Value <> "" Then Flg = False
        Cells(y, i).Value = "●"
    Next
    ' 次に縦位置探索(既に通過済と交わればフラグOFF)
    If y <= ny Then sStep = 1 Else sStep = -1
    Cells(y, nx).Value = ""     ' スタート位置クリア
    For i = y To ny Step sStep  ' 次に横位置
        If Cells(i, nx).Value <> "" Then Flg = False
        Cells(i, nx).Value = "●"
    Next

End Sub
https://twitter.com/blacklist_ryu/status/1344584745238155264?s=20
No one still commented. Please first comment.