anonymous ノック魔球2:きょろ
No License VBA
2020年12月17日
Copy Clone
Sub knock_M2a()

    Dim rng As Range: Set rng = ThisWorkbook.Worksheets("M2").UsedRange
    Dim arr() As Variant: ReDim arr(1 To rng.Rows.Count, 1 To rng.Columns.Count)
    Dim i As Long, j As Long
    
    '* 対象外セル判定&判定用配列に対象外フラグ1セット
    For i = 1 To IIf(UBound(arr, 1) > UBound(arr, 2), UBound(arr, 1), UBound(arr, 2))
        Call ps_SetValue_M2a(rng, arr)
    Next

    '* 判定用配列の対象外フラグが立っていないセルをUnion
    Dim rngTarget As Range, flg_First As Boolean: flg_First = True
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) <> 1 Then
                If flg_First Then
                    Set rngTarget = rng(i, j)
                    flg_First = False
                Else
                    Set rngTarget = Union(rngTarget, rng(i, j))
                End If
            End If
        Next
    Next
    
    '* 対象セル着色
    rngTarget.Interior.Color = vbYellow

End Sub

'*** 対象外セル判定用配列に対象外フラグ1セット
Sub ps_SetValue_M2a(prng As Range, parr As Variant)
    Dim i As Long, j As Long
    For i = 1 To UBound(parr, 1)   '* 左から右
        For j = 1 To UBound(parr, 2)
            If prng(i, j).Borders(xlEdgeLeft).LineStyle = xlNone Then
                If j = 1 Then
                    parr(i, j) = 1
                Else
                    If parr(i, j - 1) = 1 Then parr(i, j) = 1
                End If
            End If
        Next
    Next
    For j = 1 To UBound(parr, 2)   '* 上から下
        For i = 1 To UBound(parr, 1)
            If prng(i, j).Borders(xlEdgeTop).LineStyle = xlNone Then
                If i = 1 Then
                    parr(i, j) = 1
                Else
                    If parr(i - 1, j) = 1 Then parr(i, j) = 1
                End If
            End If
        Next
    Next
    For i = UBound(parr, 1) To 1 Step -1     '* 右から左
        For j = UBound(parr, 2) To 1 Step -1
            If prng(i, j).Borders(xlEdgeRight).LineStyle = xlNone Then
                If j = UBound(parr, 2) Then
                    parr(i, j) = 1
                Else
                    If parr(i, j + 1) = 1 Then parr(i, j) = 1
                End If
            End If
        Next
    Next
    For j = UBound(parr, 2) To 1 Step -1       '* 下から上
        For i = UBound(parr, 1) To 1 Step -1
            If prng(i, j).Borders(xlEdgeBottom).LineStyle = xlNone Then
                If i = UBound(parr, 1) Then
                    parr(i, j) = 1
                Else
                    If parr(i + 1, j) = 1 Then parr(i, j) = 1
                End If
            End If
        Next
    Next
End Sub
Sub knock_M2a()

    Dim rng As Range: Set rng = ThisWorkbook.Worksheets("M2").UsedRange
    Dim arr() As Variant: ReDim arr(1 To rng.Rows.Count, 1 To rng.Columns.Count)
    Dim i As Long, j As Long
    
    '* 対象外セル判定&判定用配列に対象外フラグ1セット
    For i = 1 To IIf(UBound(arr, 1) > UBound(arr, 2), UBound(arr, 1), UBound(arr, 2))
        Call ps_SetValue_M2a(rng, arr)
    Next

    '* 判定用配列の対象外フラグが立っていないセルをUnion
    Dim rngTarget As Range, flg_First As Boolean: flg_First = True
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) <> 1 Then
                If flg_First Then
                    Set rngTarget = rng(i, j)
                    flg_First = False
                Else
                    Set rngTarget = Union(rngTarget, rng(i, j))
                End If
            End If
        Next
    Next
    
    '* 対象セル着色
    rngTarget.Interior.Color = vbYellow

End Sub

'*** 対象外セル判定用配列に対象外フラグ1セット
Sub ps_SetValue_M2a(prng As Range, parr As Variant)
    Dim i As Long, j As Long
    For i = 1 To UBound(parr, 1)   '* 左から右
        For j = 1 To UBound(parr, 2)
            If prng(i, j).Borders(xlEdgeLeft).LineStyle = xlNone Then
                If j = 1 Then
                    parr(i, j) = 1
                Else
                    If parr(i, j - 1) = 1 Then parr(i, j) = 1
                End If
            End If
        Next
    Next
    For j = 1 To UBound(parr, 2)   '* 上から下
        For i = 1 To UBound(parr, 1)
            If prng(i, j).Borders(xlEdgeTop).LineStyle = xlNone Then
                If i = 1 Then
                    parr(i, j) = 1
                Else
                    If parr(i - 1, j) = 1 Then parr(i, j) = 1
                End If
            End If
        Next
    Next
    For i = UBound(parr, 1) To 1 Step -1     '* 右から左
        For j = UBound(parr, 2) To 1 Step -1
            If prng(i, j).Borders(xlEdgeRight).LineStyle = xlNone Then
                If j = UBound(parr, 2) Then
                    parr(i, j) = 1
                Else
                    If parr(i, j + 1) = 1 Then parr(i, j) = 1
                End If
            End If
        Next
    Next
    For j = UBound(parr, 2) To 1 Step -1       '* 下から上
        For i = UBound(parr, 1) To 1 Step -1
            If prng(i, j).Borders(xlEdgeBottom).LineStyle = xlNone Then
                If i = UBound(parr, 1) Then
                    parr(i, j) = 1
                Else
                    If parr(i + 1, j) = 1 Then parr(i, j) = 1
                End If
            End If
        Next
    Next
End Sub
No one still commented. Please first comment.