In the below code rngIntersect.Address returns A10. Is there way where in i can get all ranges excluding intersection without looping?
Sub NotIntersect()
Dim rng As Range, rngVal As Range, rngIntersect As Range
Set rng = Range("A1:A10")
Set rngVal = Range("A10")
Set rngIntersect = Intersect(rng, rngVal)
MsgBox rngIntersect.Address
End Sub
我已将此问题发布到 msdn 论坛，但没有得到 SO 的回复，并得到了所需的解决方案。我已经测试了代码，它工作正常。我希望它有所帮助。
这是msdn上的帖子链接。
Sub NotIntersect()
Dim rng As Range, rngVal As Range, rngDiff As Range
Set rng = Range("A1:A10")
Set rngVal = Range("A5")
Set rngDiff = Difference(rng, rngVal)
MsgBox rngDiff.Address
End Sub
Function Difference(Range1 As Range, Range2 As Range) As Range
Dim rngUnion As Range
Dim rngIntersect As Range
Dim varFormulas As Variant
If Range1 Is Nothing Then
Set Difference = Range2
ElseIf Range2 Is Nothing Then
Set Difference = Range1
ElseIf Range1 Is Nothing And Range2 Is Nothing Then
Set Difference = Nothing
Else
Set rngUnion = Union(Range1, Range2)
Set rngIntersect = Intersect(Range1, Range2)
If rngIntersect Is Nothing Then
Set Difference = rngUnion 'Updated "Different" to "Difference"
Else
varFormulas = rngUnion.Formula
rngUnion.Value = 0
rngIntersect.ClearContents
Set Difference = rngUnion.SpecialCells(xlCellTypeConstants)
rngUnion.Formula = varFormulas
End If
End If
End Function
您正在寻找的是集合论术语中的“补语”。参见维基百科。这可以在不遍历两个范围内的每个单元格的情况下完成（这对于具有许多单元格的范围来说将是一个巨大的开销），但是您需要遍历范围内的每个区域。该循环快速有效。这是代码：
Public Function NotIntersect(Range1 As Range, Range2 As Range) As Range
Dim NewRange As Range, CurrentArea As Range, CurrentNewArea(1 To 4) As Range, r As Range
Dim c%, a%
Dim TopLeftCell(1 To 2) As Range, BottomRightCell(1 To 2) As Range
Dim NewRanges() As Range, ColNewRanges() As New Collection
Const N% = 2
Const U% = 1
If Range1 Is Nothing And Range2 Is Nothing Then
Set NotIntersect = Nothing
ElseIf Range1.Address = Range2.Address Then
Set NotIntersect = Nothing
ElseIf Range1 Is Nothing Then
Set NotIntersect = Range2
ElseIf Range1 Is Nothing Then
Set NotIntersect = Range1
Else
Set TopLeftCell(U) = Range1.Cells(1, 1)
Set BottomRightCell(U) = Range1.Cells(Range1.Rows.Count, Range1.Columns.Count)
c = Range2.Areas.Count
ReDim ColNewRanges(1 To c)
ReDim NewRanges(1 To c)
For a = 1 To c
Set CurrentArea = Range2.Areas(a)
Set TopLeftCell(N) = CurrentArea.Cells(1, 1)
Set BottomRightCell(N) = CurrentArea.Cells(CurrentArea.Rows.Count, CurrentArea.Columns.Count)
On Error Resume Next
Set ColNewRanges(a) = New Collection
ColNewRanges(a).Add Range(TopLeftCell(U), Cells(TopLeftCell(N).Row - 1, BottomRightCell(U).Column))
ColNewRanges(a).Add Range(Cells(TopLeftCell(N).Row, TopLeftCell(U).Column), Cells(BottomRightCell(N).Row, TopLeftCell(N).Column - 1))
ColNewRanges(a).Add Range(Cells(TopLeftCell(N).Row, BottomRightCell(N).Column + 1), Cells(BottomRightCell(N).Row, BottomRightCell(U).Column))
ColNewRanges(a).Add Range(Cells(BottomRightCell(N).Row + 1, TopLeftCell(U).Column), BottomRightCell(U))
On Error GoTo 0
For Each r In ColNewRanges(a)
If NewRanges(a) Is Nothing Then
Set NewRanges(a) = r
Else
Set NewRanges(a) = Union(NewRanges(a), r)
End If
Next r
Next a
For a = 1 To c
If NewRange Is Nothing Then
Set NewRange = NewRanges(a)
Else
Set NewRange = Intersect(NewRange, NewRanges(a))
End If
Next a
Set NotIntersect = Intersect(Range1, NewRange) 'intersect required in case it's on the bottom or right line, so a part of range will go beyond the line...
End If
End Function
测试如下：
Sub Test1()
NotIntersect(Range("$A$1:$N$24"), Range("$G$3:$H$12,$C$4:$D$7,$A$13:$A$15")).Select
End Sub
据我所知，没有“干净”的功能。如果要求“无循环”很重要，您可以尝试以下方法（这是一种“方法”，而不是工作代码）：
- create a new sheet
- find intersection of ranges
- set range from top left to bottom right of intersection to 0
- set range1 to 1
- set all values in range2 = XOR of values that are there (so 1 becomes 0, and 0 becomes 1)
- find all cells with a 1 - their address is the "non-intersection"
- delete the temp sheet
我相信这些都可以在没有循环的情况下完成 - 但这是一个可怕的黑客......