Get Outer Bounding Range of Union with Multiple Areas

Question

Looked high and low, and I haven't found anyone who has talked about this: I have 2 or more ranges that have been "Unioned" in VBA (so rngUnion.Areas.Count >= 2) and the area ranges are partially contiguous (e.g. rngUnion.Areas(1).address = "A1:Y75", rngUnion.Areas(2).address = "A76:U123", etc.).

What is the simple/efficient way to get the outer bounding range object of the combine areas within rngUnion? I have code below that does this but it seems super kludgy and dumb - I am sure that there is a better way.

Note: I am assuming that there could be other used cells around these areas that are not with the union so I am extremely hesitant to use .CurrentRegion, .UsedRange, or .End(xlUp).Row type methods that are all being suggested for working with ranges.

Sub SomeObfuscatedMethodForGettingAUnionOfPartiallyContiguousAreas()
    Dim rng1 As Range: Set rng1 = Range("A1:Y75")
    Dim rng2 As Range: Set rng2 = Range("A76:U123")
    Dim rngUnion As Range, rngComplete As Range
    
    Set rngUnion = Union(rng1, rng2)
    
    Set rngComplete = GetOuterBoundingRange(rngUnion)
    Debug.Print rngComplete.Address 'prints "A1:Y123"
End Sub

Function GetOuterBoundingRange(rngUnion As Range) As Range
        Dim minRow As Long: minRow = 2147483647
        Dim minCol As Long: minCol = 2147483647
        Dim maxRow As Long: maxRow = 0
        Dim maxCol As Long: maxRow = 0
        Dim minRowTemp As Long
        Dim minColTemp As Long
        Dim maxRowTemp As Long
        Dim maxColTemp As Long
        Dim area As Range
        
        For Each area In rngUnion.Areas
            minRowTemp = area.Row
            maxRowTemp = minRowTemp + area.Rows.Count - 1
            minColTemp = area.Column
            maxColTemp = minColTemp + area.Columns.Count - 1
            
            If minRowTemp < minRow Then minRow = minRowTemp
            If minColTemp < minCol Then minCol = minColTemp
            If maxRowTemp > maxRow Then maxRow = maxRowTemp
            If maxColTemp > maxCol Then maxCol = maxColTemp
        Next area
        With rngUnion.parent        
            Set GetOuterBoundingRange = .Range(.Cells(minRow, minCol), .Cells(maxRow, maxCol))
        End With
End Function

Answer 1

As far as I know, there is no build-in function to do so. I don't think your function is that clumsy, in all cases you will need to loop over all areas and find the min and max row and column.

My attempt is a little bit shorter by collecting the numbers into arrays and uses the Min and Max-function, but basically it's doing the same.

Function getR(r As Range) As Range
    ReDim minRow(1 To r.Areas.Count) As Long
    ReDim maxRow(1 To r.Areas.Count) As Long
    ReDim minCol(1 To r.Areas.Count) As Long
    ReDim maxCol(1 To r.Areas.Count) As Long
    
    Dim i As Long
    For i = 1 To r.Areas.Count
        minRow(i) = r.Areas(i).Row
        maxRow(i) = r.Areas(i).Row + r.Areas(i).Rows.Count
        minCol(i) = r.Areas(i).Column
        maxCol(i) = r.Areas(i).Column + r.Areas(i).Columns.Count
    Next
    With r.Parent
        Set getR = .Range(.Cells(WorksheetFunction.Min(minRow), WorksheetFunction.Min(minCol)), _
                          .Cells(WorksheetFunction.Max(maxRow) - 1, WorksheetFunction.Max(maxCol) - 1))
    End With

End Function

Answer 2

This function uses the Application.Range property (Excel) to create the Range Around the Union Range.

Function UnionRange_ƒRangeAround_Set(rUnion As Range) As Range
Dim rOutput As Range, b As Byte
        
    With rUnion
        Set rOutput = .Areas(1)
        For b = 2 To .Areas.Count
            Set rOutput = Range(rOutput, .Areas(b))
        Next
    End With

    Set UnionRange_ƒRangeAround_Set = rOutput
    
    End Function

Answer 3

Since I brought it up, here is a solution which uses a regular expressions. Note for it to work you would need to set a reference to "Microsoft VBScript Regular Expressions 5.5". I pulled all the numbers out of the R1C1 address and used the fact that row numbers and column numbers would alternate, so it would fail if the range in question involved row only or column only references (eg, R3:R4 would break it).

Function getOuterBoundingRange(rngUnion As Range) As Range
    Dim regEx As New RegExp
    Dim m As Match, oMat As MatchCollection
    Dim rowsArr() As Variant
    Dim colsArr() As Variant
    
    With regEx
        .Global = True
        .Pattern = "\d+"
    End With
    
    Set oMat = regEx.Execute(rngUnion.Address(, , xlR1C1))
    ReDim rowsArr(0 To oMat.Count / 2 - 1)
    ReDim colsArr(0 To oMat.Count / 2 - 1)
    
    i = 0
    For Each m In oMat
        If (i / 2) = Int(i / 2) Then
            rowsArr(i / 2) = CLng(m.Value)
        Else
            colsArr(Int(i / 2)) = CLng(m.Value)
        End If
        i = i + 1
    Next m
    
    With rngUnion.Parent
        Set getOuterBoundingRange = .Range(.Cells(WorksheetFunction.Min(rowsArr), WorksheetFunction.Min(colsArr)), _
                                           .Cells(WorksheetFunction.Max(rowsArr), WorksheetFunction.Max(colsArr)))
    End With
    
End Function

Answer 4

Alternative via tricky FilterXML() - //Late Edit as of 2021-11-14

Instead of looping through all areas cell by cell or applying regEx, I demonstrate how to resolve OP's question alternatively via FilterXML().

I extended @Professor Pantsless'es clever idea to use a R1C1 address of a range Union, but parsed the address into two parts: the first with entire row indices, and the second with entire column indices.

This allows a minimum/maximum filtering without loops, executed by XPath expressions via FilterXML() (~> see help function getBoundaries).

Function getR(r As Range) As Range
'a) get Boundaries
    Dim rc() As Long: rc = getBoundaries(r)
'b) get entire range
    With r.Parent
        Set getR = .Range(.Cells(rc(1), rc(2)), _
                        .Cells(rc(3), rc(4)))
    End With
End Function

Help function getBoundaries()

Includes the main logic using FilterXML() in three steps:

• a) define XPath expressions to find minimal/maximal row/column indices.
• b) build a wellformed xml content string by tokenizing the Union range address (where R1C1 mode allows to get numeric values) - uses a further help function getContent().
• c) apply FilterXML() based on a wellformed xml content and XPath expressions returning results as a 4-elements array with outer range boundaries.

Function getBoundaries(r As Range) As Long()
'Purp.: return boundaries of range union
'Site:  https://stackoverflow.com/questions/69572123/get-outer-bounding-range-of-union-with-multiple-areas
'Date:  2021-10-15
'Auth:  [T.M](https://stackoverflow.com/users/6460297/t-m)
'a) define XPath patterns
    Const min As String = "//i[not(../i < .)][1]"
    Const max As String = "//i[not(../i > .)][1]"
'b)get wellformed xml content (rows|columns) 
    Dim content As String
'c1)get Row boundaries
    content = getContent(r, True)                 ' help function getContent()
    Dim tmp(1 To 4) As Long
    tmp(1) = Application.FilterXML(content, min)
    tmp(3) = Application.FilterXML(content, max)
'c2)get Column boundaries
    content = getContent(r, False)                ' << corrected misspelling 2021-11-14 to getContent (inst/of wellformed()
    tmp(2) = Application.FilterXML(content, min)
    tmp(4) = Application.FilterXML(content, max)
'd) return boundaries array
    getBoundaries = tmp
End Function

Help function getContent() (called by above function in section b))

Function getContent(r As Range, ExtractRows As Boolean) As String
'Purp.: get wellformed XML content string
'Meth.: tokenize R1C1-range address into html-like tags
    Dim tmp As String
    If ExtractRows Then     ' extract row numbers
        tmp = r.EntireRow.Address(ReferenceStyle:=xlR1C1)
        getContent= "<rc><i>" & Replace(Replace(Replace(tmp, "R", ""), ",", ":"), ":", "</i><i>") & "</i></rc>"
    Else                    ' extract column numbers
        tmp = r.EntireColumn.Address(ReferenceStyle:=xlR1C1)
        getContent= "<rc><i>" & Replace(Replace(Replace(tmp, "C", ""), ",", ":"), ":", "</i><i>") & "</i></rc>"
    End If
End Function

Further links

I recommend reading @JvdV 's excellent & nearly encyclopaedic post Extract substrings from string using FilterXML().