vba - 测试两个范围对象是否引用同一范围

Question

我想找到一种更智能的方法来测试两个范围对象实际上是否引用相同的范围:

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")

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

除了逐个单元检查并检查 Intersect() 是否不是 Nothing 之外，还有什么算法可以解决此问题？

Answer 1

几年前，我在另一个论坛上编写了这段代码，作为添加 Subtract Range 选项的快速方法，与我在 Fast method for determining unlocked cell range 中使用的方法相同。

背景

此函数接受两个范围，删除两个范围相交的单元格，然后生成包含缩小范围的地址的字符串输出。这是通过以下方式完成的:

• 创建一个新的单页WorkBook
• 在 rng1 中包含的此工作表上的所有单元格中输入 N/A 公式，
• 清除此工作表上 rng2 包含的所有单元格的内容，
• 使用 SpecialCells 返回剩余的 N/A 公式，这些公式表示 rng1 中未在 rng2 中找到的单元格，
• 如果 bool 变量 bBothRanges 设置为 True，则对具有相反范围顺序的单元格重复该过程，
• 然后代码以字符串形式返回“缩小的”范围，然后关闭工作簿。

举个例子:

'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

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

对于您提供的非常短的范围，一个简单的单元格循环就足够了，对于更大的范围，这个快捷方式可能很有用。

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

主要

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