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（）不是没有什么算法是否存在这个问题？

Answer 1

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

背景

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

创建新的单页WorkBook
将N / A公式输入rng1，
清除此工作表中rng2，
使用SpecialCells返回剩余的N / A公式，表示rng1中未在rng2中找到的单元格，
如果布尔变量bBothRanges设置为True，则使用具有相反范围顺序的单元格重复该过程，
然后代码返回＆＃34;减少＆＃34;范围作为字符串，然后关闭工作簿。

举个例子：

'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

Answer 2

您可以随时手动执行此操作：

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

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

2 个答案: