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

我想找一个更明智的方法来testing两个范围对象实际上是否指向相同的范围：

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，而在将这些范围中的任何一个范围与包含不属于第一个范围的单元格或不包含来自第一个范围的单元格。

什么algorithm，而不是逐个单元格，并检查Intersect（）是不是没有这个问题？

Answer 1

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

背景

此函数接受两个范围，删除两个范围相交的单元格，然后生成一个包含缩小范围地址的string输出。 这是通过：

• 创build一个新的一张工作WorkBook
• 将N / A公式input到rng1包含的所有单元格中，
• 清除rng2中包含的此表上所有单元格的内容，
• 使用SpecialCells返回表示rng1中未在rng2中find的单元格的剩余N / A公式，
• 如果将布尔variablesbBothRanges设置为True ，则对具有相反范围顺序的单元重复该过程，
• 该代码然后返回“缩小”的范围作为一个string，然后closures工作簿。

举个例子：

 '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