测试两个范围对象是否指向相同的范围

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.

我正在尝试编写的函数在比较上述任何一对范围时必须返回True,并且在将这些范围中的任何一个与包含不属于第一个范围的单元格或不包含第一个范围内的某些单元格的范围进行比较时为False 。

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

什么算法除了逐个单元格并检查Intersect()不是什么都没有这个问题?

2 个解决方案

#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

几年前我在另一个论坛上编写了这段代码作为添加Subtract Range选项的快速方法,我在Fast方法中用于确定解锁单元格范围的方法相同

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

创建一个新的单页WorkBook

entering the N/A formula into all the cells on this sheet contained in rng1,

将N / A公式输入到rng1中包含的此工作表上的所有单元格中,

clearing the contents of all cells on this sheet that are contained by rng2,

清除rng2包含的此工作表上所有单元格的内容,

using SpecialCells to return the remaining N/A formulae which represents the cells in rng1 that are not found in rng2,

使用SpecialCells返回剩余的N / A公式,表示rng1中未在rng2中找到的单元格,

If the Boolean variable, bBothRanges, is set to True, then the process is repeated with the cells with the opposite range order,

如果布尔变量bBothRanges设置为True,则使用具有相反范围顺序的单元格重复该过程,

the code then returns the "reduced" range as a string, then closes the WorkBook.

然后代码将“减少”范围作为字符串返回,然后关闭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.

在您的情况下,代码运行bBothRanges选项,然后检查RemoveIntersect是否返回vbNullString以查看范围是否相同。

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

#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

#1