Test if two range objects refer to the same range

Question

I want to find a smarter way to test if two range objects, in fact, refer to the same range:

Set A = Range("B1:B3,A2:C2")
Set B = Range("B1,A2:C2,B3")
Set C = Range("A2,B1:B3,C2")
Set D = Range("B1,A2,B2,C2,B3")

The function I'm trying to write must return True when comparing any pair of ranges described above, and False when comparing any of those ranges to a range containing cells that are not part of the first range or not containing some cells from the first range.

What algorithm other than going cell by cell and checking that Intersect() is not Nothing is there for this problem?

Answer 1

I use;

Function RaC_SameRa(iRa1 As Range, iRa2 As Range, Optional iSucBothNothing As Boolean) As Boolean

'Succeeds if iRa1 and iRa2 refer to the same Range, ie have the Same External Address
'   Fails if iRa1 and iRa2 are Both Nothing, unless iSucBothNothing is Set

On Error Resume Next
RaC_SameRa = iRa1.Address(, , , True) = iRa2.Address(, , , True)
If iSucBothNothing Then _
    If Not RaC_SameRa Then _
        RaC_SameRa = iRa1 Is Nothing And iRa2 Is Nothing
End Function

Answer 2

If you store the address of each element of a range in a dictionary, repeated cells are eliminated and the dictionary size is the correct cell count. This code builds upon the idea of @Paul Deaton and such a count function:

Function cellct(rg As Range) As Long
    Dim x As Range
    Dim dict As Scripting.Dictionary
    
    Set dict = New Scripting.Dictionary
    
    For Each x In rg
        dict(x.Address) = True
    Next x
    cellct = dict.Count
    Set dict = Nothing
End Function

Function RangesEqual(rg1 As Range, rg2 As Range) As Boolean
    Dim n1 As Long
    
    n1 = cellct(rg1)
    RangesEqual = (n1 = cellct(rg2)) And (n1 = cellct(Union(rg1, rg2)))
End Function

Edit:

touching all cells involved, creating multiple dictionaries etc. comes at the price of slow performance. This version is optimized for speed but readability is poor and memory consumption is higher. Tested with ranges of a couple of thousand cells showed a 2x improvement:

Function RangesEqual(ByVal rg1 As Range, ByVal rg2 As Range) As Boolean
' 2023-12-28
' ByVal because rg1, rg2 might be swapped here

    Dim n1 As Long
    Dim x As Range
    Dim s As String
    Dim dict1 As Scripting.Dictionary
    Set dict1 = New Scripting.Dictionary
    Dim dict2 As Scripting.Dictionary
    Set dict2 = New Scripting.Dictionary
    
    ' count the smaller range
    If rg1.Cells.Count > rg2.Cells.Count Then
        Set x = rg1
        Set rg1 = rg2
        Set rg2 = x
    End If
    
    For Each x In rg1
        dict1(x.Address) = True
    Next x
    n1 = dict1.Count
    
    ' shortcut exit if unequal
    RangesEqual = False
    For Each x In rg2
        s = x.Address    ' this is expensive
        dict2(s) = True  ' count
        If dict2.Count > n1 Then Exit Function
        ' test rg2 == Union(rg1, rg2)
        If Not dict1.Exists(s) Then Exit Function
    Next x
    RangesEqual = (dict2.Count = n1) ' rg2 might be shorter
End Function

optimizations: only the smaller range will be put into a dict completely. While going through the other range there is always the chance of exiting quickly. So the worst case is handling len(rg1) + len(rg2) cells if both ranges are indeed identical.

Then, no function calls.

And lastly, no need to actually create a Union(rg1, rg2) but testing the relevant condition on the fly.

Answer 3

I know this is an old question, but the OP and others could use this:

If Rg1.Cells.Count = Rg2.Cells.Count and Rg1.Cells.Count = Union(Rg1,Rg2).Cells.Count Then MsgBox "Ranges are identical"

Answer 4

I wrote this code on another forum some years back as a quick method to add a Subtract Range option, the same approach I used in Fast method for determining unlocked cell range

background

This function accepts two ranges, removes the cells where the two ranges intersect, and then produces a string output containing the address of the reduced range. This is done by:

• creating a new one-sheet WorkBook
• entering the N/A formula into all the cells on this sheet contained in rng1,
• clearing the contents of all cells on this sheet that are contained by rng2,
• using SpecialCells to return the remaining N/A formulae which represents the cells in rng1 that are not found in rng2,
• If the Boolean variable, bBothRanges, is set to True, then the process is repeated with the cells with the opposite range order,
• the code then returns the "reduced" range as a string, then closes the WorkBook.

As an example:

'Return the hidden cell range on the ActiveSheet
Set rngTest1 = ActiveSheet.UsedRange.Cells
Set rngTest2 = ActiveSheet.UsedRange.SpecialCells(xlVisible)

If rngTest1.Cells.Count > rngTest2.Cells.Count Then
    strTemp = RemoveIntersect(rngTest1, rngTest2) 
    MsgBox "Hidden cell range is " & strTemp, vbInformation
Else
    MsgBox "No hidden cells", vbInformation
End If

In your case the code runs the bBothRanges option and then checks if the RemoveIntersect returns vbNullStringto see if the ranges are the same.

For very short ranges as you have provided, a simple cell by cell loop would suffice, for larger ranges this shortcut may be useful.

Sub Test()
Dim A As Range, B As Range, C As Range, D As Range
Set A = Range("B1:B3,A2:C2")
Set B = Range("B1,A2:C2,B3")
Set C = Range("A2,B1:B3,C2")
Set D = Range("B1,A2,B2,C2,B3")

MsgBox RemoveIntersect(A, B, True) = vbNullString    
End Sub

main

Function RemoveIntersect(ByRef rng1 As Range, ByRef rng2 As Range, Optional bBothRanges As Boolean) As String
    Dim wb As Workbook
    Dim ws1 As Worksheet
    Dim rng3 As Range
    Dim lCalc As Long

    'disable screenupdating, event code and warning messages.
    'set calculation to Manual
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        lCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    'add a working WorkBook
    Set wb = Workbooks.Add(1)
    Set ws1 = wb.Sheets(1)

    On Error Resume Next
    ws1.Range(rng1.Address).Formula = "=NA()"
    ws1.Range(rng2.Address).Formula = vbNullString
    Set rng3 = ws1.Cells.SpecialCells(xlCellTypeFormulas, 16)
    If bBothRanges Then
        ws1.UsedRange.Cells.ClearContents
        ws1.Range(rng2.Address).Formula = "=NA()"
        ws1.Range(rng1.Address).Formula = vbNullString
        Set rng3 = Union(rng3, ws1.Cells.SpecialCells(xlCellTypeFormulas, 16))
    End If
    On Error GoTo 0
    If Not rng3 Is Nothing Then RemoveIntersect = rng3.Address(0, 0)

    'Close the working file
    wb.Close False
    'cleanup user interface and settings
    'reset calculation
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        lCalc = .Calculation
    End With

End Function

Answer 5

You could always do it manually, like this:

Private Function isRangeEquivalent(ByRef range1 As Range, ByRef range2 As Range) As Boolean

    isRangeEquivelent = (range1.Cells.Count = range2.Cells.Count)

    If isRangeEquivelent Then
        Dim addresses As collection
        Set addresses = New collection
        Dim cell As Range
        For Each cell In range1.Cells
            Call addresses.Add(cell.Address, cell.Address)
        Next cell
        For Each cell In range2.Cells
            If Not isInCollection(addresses, cell.Address) Then
                isRangeEquivelent = False
                Exit For
            End If
        Next cell
    End If
End Function

Private Function isInCollection(ByRef collection As collection, ByVal sKey As String)

    On Error GoTo Catch
    collection.Item sKey
    isInCollection = True
    Exit Function
Catch:
    isInCollection = False
End Function