Excelで枠線で囲まれたセルの範囲を取得する VBA Function

Excelで上図のように矩形の枠線で囲まれたセルの範囲(Rangeオブジェクト)を取得するVBAのFunctionを作成したのでメモ。Excelでセルの結合はなされていないが、枠線で囲まれているので「一つの項目」として扱われている対象を取り出すために作成してみた。上図のサンプルに対するこのコードの出力はメッセージボックスに "0 $B$2:$D$8"と表示される。

Option Explicit

Sub test02()
    Dim s As Worksheet
    Dim rRoot As Range, rRange As Range
    Dim sLeftTop As String, sRightBottom As String, c
    Dim flagError As Integer
    Set s = ThisWorkbook.Worksheets("Sheet1")
    Set rRoot = s.Range("B4")
    Set rRange = s.Range("A1:D8")
    MsgBox flagError & vbNewLine & seekRangeRectangularBorders(rRoot, rRange, flagError).Address
End Sub

Function seekRangeRectangularBorders( _
    ByVal rSeekRoot As Range, ByVal rSeekRange As Range, ByRef flagError As Integer _
) As Range
    '
    ' 矩形の枠線に囲まれた Range を求める。
    '
    ' 入力
    '   rSeekRoot As Range 探索の起点(複数セルを含むとき、左上隅セルが起点になる)
    '   rSeekRange As Range 探索の範囲
    '   flagError As Integer [探索に成功(失敗がない)]0,
    '     [失敗：起点が探索範囲外]1, [失敗：探索中に範囲外に出た]2
    '
    ' 戻り値
    '   [探索に成功]枠で囲まれたRange
    '   [失敗]起点のRange
    '
    Dim iColumn As Integer, iColumnMax As Integer, iColumnMin As Integer
    Dim iRow As Integer, iRowMin As Integer, iRowMax As Integer
    Dim iRColumnMax As Integer, iRColumnMin As Integer
    Dim iRRowMin As Integer, iRRowMax As Integer
    Dim rBuf As Range
    If rSeekRoot = Application.Intersect(rSeekRoot, rSeekRange) Then ' 探索範囲と起点の重なりチェック
        iColumnMin = 1: iRowMin = 1:
        iColumnMax = 1: iRowMax = 1:
        iRColumnMin = rSeekRange.Cells(1, 1).Column - rSeekRoot.Cells(1, 1).Column + 1
        iRColumnMax = rSeekRange.Cells(1, rSeekRange.Columns.Count).Column _
            - rSeekRoot.Cells(1, 1).Column + 1
        iRRowMin = rSeekRange.Cells(1, 1).Row - rSeekRoot.Cells(1, 1).Row + 1
        iRRowMax = rSeekRange.Cells(rSeekRange.Rows.Count, 1).Row - rSeekRoot.Cells(1, 1).Row + 1
        '
        ' 枠線の探索ループ:
        '
        Do
            Set rBuf = Range(rSeekRoot.Cells(iRowMin, iColumnMin), rSeekRoot.Cells(iRowMax, iColumnMax))
            If rBuf.Borders(xlEdgeTop).LineStyle = -4142 Then iRowMin = iRowMin - 1
            If rBuf.Borders(xlEdgeLeft).LineStyle = -4142 Then iColumnMin = iColumnMin - 1
            If rBuf.Borders(xlEdgeBottom).LineStyle = -4142 Then iRowMax = iRowMax + 1
            If rBuf.Borders(xlEdgeRight).LineStyle = -4142 Then iColumnMax = iColumnMax + 1
            '
            ' 探索範囲内チェック
            '
            If iRowMin < iRRowMin Or iRowMax > iRRowMax _
            Or iColumnMin < iRColumnMin Or iColumnMax > iRColumnMax Then
                flagError = 2
                Set seekRangeRectangularBorders = rSeekRoot
                Exit Function
            End If
        Loop While rBuf.Address <> _
        Range(rSeekRoot.Cells(iRowMin, iColumnMin), rSeekRoot.Cells(iRowMax, iColumnMax)).Address
        flagError = 0
        Set seekRangeRectangularBorders = rBuf
    Else
        flagError = 1
        Set seekRangeRectangularBorders = rSeekRoot
    End If
End Function