Get Outer Bounding Range of Union with Multiple Areas-CodePudding

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
        Set GetOuterBoundingRange = Range(Cells(minRow, minCol), Cells(maxRow, maxCol))
End Function

CodePudding user response：

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

CodePudding user response：

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) = CInt(m.Value)
        Else
            colsArr(Int(i / 2)) = CInt(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

CodePudding user response：

Approach via tricky FilterXML() execution

I saw it as a challenge to resolve OP's question not via RegEx, but alternatively via FilterXML().

Based on @Professor Pantsless'es tricky idea to use a R1C1 address of a range Union, it was the main problem to find valid XPath expressions finding minima/maxima to be applied on a series of successive row and column numbers put into tokenized xml nodes.

Caveat: In order to keep it simple, assumption is made that all areas form a pair of cell boundaries like e.g. A1:Y75,A76:U123 and don't include single cell areas; of course this caveat can be overcome programmatically in extending the getContent() help function!

Function getRX(r As Range) As Range
'1) get all range boundaries (4-elements: top row/col, end row/col numbers)
    Dim rc() As Long
    rc = getBoundaries(r)   ' << main logic in help function using FilterXML
'2) return outer bounding range
    With r.Parent
        Set getRX = .Range(.Cells(rc(1), rc(2)), _
                           .Cells(rc(3), rc(4)))
    End With
    'Debug.Print getRX.Address         ' ~~> e.g. $A$1:$Y$123 
End Function

Help function getBoundaries()

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

a) 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().
b) define XPath expressions to find minimal/maximal row/column indices.
c) apply FilterXML() based on content and XPath inputs and return results as a 4-elements array.

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) build wellformed xml content
    Dim content As String
    content = getContent(r)
'b) define lo(w)|hi(gh) XPath expressions
    Dim lo As String, hi As String
    lo = "//i[position() mod 4 = $ and . <= ../i[position() mod 4 = $]][1]"
    hi = "//i[position() mod 4 = $ and not(. < ../i[position() mod 4 = $])][1]"
'c) assign row/column indices to array rc
    Dim i As Long, rc(1 To 4) As Long
    For i = 1 To 2      ' minimal row/col indices
        rc(i) = Application.FilterXML(content, Replace(lo, "$", i))
    Next
    For i = 3 To 4      ' maximal row/col indices
        rc(i) = Application.FilterXML(content, Replace(hi, "$", i Mod 4))
    Next
'd) return function results
    getBoundaries = rc
End Function

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

Function getContent(r As Range) As String
'Purp.: get wellformed XML content string
'Meth.: tokenize R1C1-range address into html-like tags
    Dim tmp
    tmp = r.Address(ReferenceStyle:=xlR1C1)
    tmp = Split(Replace(Replace(Replace(tmp, ",", ":"), "R", ""), "C", ":"), ":")
    getContent = "<rc><i>" & Join(tmp, "</i><i>") & "</i></rc>"
End Function