VBA100本ノック 魔球編2 閉領域の塗り潰し

mod_VBA100_MagicBall002.bas

Rem VBA100本ノック 魔球編2 閉領域の塗り潰し
Option Explicit

Private Const NN未探索 = 0   '初期値。最終的に色を塗る対象となる
Private Const NN探索対象 = 1 '四方探索が予約された状態（最終的に0件となる）
Private Const NN探索済 = 2   '四方探索を終えた状態（領域外から繋がっている島ではない箇所）

Sub Main()
    Dim rng As Range
    Set rng = Worksheets("問").UsedRange
    rng.Select
    Call Knock_MagicBall002(rng)
End Sub

Sub Knock_MagicBall002(rng As Range)
    Rem 現在の探索状態を示すフラグ
    Dim arrV
    ReDim arrV(0 To rng.Rows.Count + 1, 0 To rng.Columns.Count + 1)
    
    Rem 各セルのボーダーラインのキャッシュ
    Dim arrB
    ReDim arrB(0 To rng.Rows.Count + 1, 0 To rng.Columns.Count + 1)
    Call CreateBordersArray(rng, arrB)
    
    Rem スタート地点は領域外(どこでも良い）
    arrV(LBound(arrV, 1), LBound(arrV, 2)) = 1
'    arrV(UBound(arrV, 1), UBound(arrV, 2)) = 1
    
    Rem 全面を探索してN探索対象=1の箇所を基準に四方を調べる
    Dim i As Long, j As Long, n残りの探索対象 As Long
    Do
        n残りの探索対象 = 0
        For i = LBound(arrV, 1) To UBound(arrV, 1)
            For j = LBound(arrV, 2) To UBound(arrV, 2)
                If arrV(i, j) = NN探索対象 Then
                    n残りの探索対象 = n残りの探索対象 + 1
                    Call AreaSearch(arrV, arrB, i, j)
                    
                    Rem 確認用着色
'                    Call DrawCell(rng, arrV)
'                    rng.Cells(i, j).Interior.Color = vbRed
                End If
            Next
        Next
        Rem 無限ループ対策安全装置
'        DoEvents
        If n残りの探索対象 = 0 Then Exit Do
    Loop
    
    Rem 実行結果の描画
    Call DrawCell(rng, arrV)
End Sub

Rem 四方の罫線情報を格納した二次元配列を作成する
Sub CreateBordersArray(rng As Range, ByRef arrB)
    Dim i As Long, j As Long
    
    Rem L T B Rを入れるジャグ配列作成
    For i = LBound(arrB, 1) To UBound(arrB, 1)
        For j = LBound(arrB, 2) To UBound(arrB, 2)
            arrB(i, j) = Array(xlLineStyleNone, xlLineStyleNone, xlLineStyleNone, xlLineStyleNone)
        Next
    Next
    
    Rem 対象セルと隣接セルに罫線情報を入れる
    Rem これにより対象セルの周りにも罫線情報を格納する
    For i = 1 To rng.Rows.Count
        For j = 1 To rng.Columns.Count
            Dim k As Long
            For k = 0 To 3
                Dim ofs: ofs = OffsetRCsLTBR(k)
                arrB(i, j)(k) = rng.Cells(i, j).Borders(xlEdgeLeft + k).LineStyle
'                Stop
                Select Case k
                    Case 0: arrB(i + ofs(0), j + ofs(1))(3) = arrB(i, j)(k)
                    Case 1: arrB(i + ofs(0), j + ofs(1))(2) = arrB(i, j)(k)
                    Case 2: arrB(i + ofs(0), j + ofs(1))(1) = arrB(i, j)(k)
                    Case 3: arrB(i + ofs(0), j + ofs(1))(0) = arrB(i, j)(k)
                End Select
            Next
        Next
    Next
End Sub

Rem 指定したセルを基準に罫線がない方向の隣接セルを探索する
Sub AreaSearch(arrV, arrB, i, j)
    Dim MinX As Long: MinX = 0
    Dim MinY As Long: MinY = 0
    Dim MaxX As Long: MaxX = UBound(arrV, 1)
    Dim MaxY As Long: MaxY = UBound(arrV, 2)
    
    Rem 4方向 0:L 1:T 2:B 3:R
    Dim k As Long
    For k = 0 To 3
        Dim ofs: ofs = OffsetRCsLTBR(k)
        Rem 指定方向に罫線が無いか
        If arrB(i, j)(k) = xlLineStyleNone Then
            Rem 領域外か
            If i + ofs(0) < MinX Or i + ofs(0) > MaxX Or j + ofs(1) < MinY Or j + ofs(1) > MaxY Then
            Rem 領域内か
            Else
                Rem 未探索箇所を探索場所とする
                If arrV(i + ofs(0), j + ofs(1)) = NN未探索 Then
                    arrV(i + ofs(0), j + ofs(1)) = NN探索対象
                End If
            End If
        End If
    Next
    
    Rem 探索完了
    arrV(i, j) = NN探索済
End Sub

Rem 4方向 0:L 1:T 2:B 3:R
Function OffsetRCsLTBR()
    OffsetRCsLTBR = Array(Array(0, -1), Array(-1, 0), Array(1, 0), Array(0, 1))
End Function

Rem 配列の値に従ってセルを着色
Sub DrawCell(rng As Range, arrV)
    Application.ScreenUpdating = False
    Dim i As Long, j As Long
    For i = 1 To rng.Rows.Count
        For j = 1 To rng.Columns.Count
            'rng.Cells(i, j).Value = arrV(i, j)
            Dim nColorIndex  As Long
            Select Case arrV(i, j)
                Case NN未探索: nColorIndex = 6
                Case NN探索対象: nColorIndex = 10
                Case NN探索済: nColorIndex = xlColorIndexNone
            End Select
            rng.Cells(i, j).Interior.ColorIndex = nColorIndex
        Next
    Next
    Application.ScreenUpdating = True
End Sub

#VBA100本ノック の 魔球編2 閉領域の塗り潰し の解答例です。

出題ツイート
https://twitter.com/yamaoka_ss/status/1339137681419223040

解説記事
https://excel-ubara.com/vba100/VBA100_M002.html

ライブコーディング動画
https://youtu.be/YnXk-ydbx9g