excel - 非相交范围 VBA

Question

在下面的代码中，rngIntersect.Address 返回A10。有没有办法可以在不循环的情况下获得除交集之外的所有范围？

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

Answer 1

您正在寻找的是集合论术语中的“补集”。请参阅Wikipedia 。无需循环遍历两个范围中的每个单元格即可完成此操作(对于具有许多单元格的范围来说，这将是巨大的开销)，但您需要循环遍历范围内的每个区域。该循环快速且高效。代码如下:

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