Test if two range objects refer to the same range - vba

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 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 2

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