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

我已经将此问题发布到msdn论坛，因为SO没有响应，并获得了所需的解决方案。我测试了代码，它工作正常。我希望它有所帮助。

以下是msdn上发布的link。

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 Different = Nothing
        Else
            Set rngUnion = Union(Range1, Range2)
            Set rngIntersect = Intersect(Range1, Range2)
            If rngIntersect Is Nothing Then
                Set Difference = rngUnion
            Else
                varFormulas = rngUnion.Formula
                rngUnion.Value = 0
                rngIntersect.ClearContents
                Set Difference = rngUnion.SpecialCells(xlCellTypeConstants)
                rngUnion.Formula = varFormulas
            End If
        End If
    End Function

Answer 2

据我所知，没有“清洁”功能。如果要求“无循环”很重要，您可以尝试以下（这是一种“方法”，而不是工作代码）：

- 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

我相信每一个都可以在没有循环的情况下完成 - 但这是一个糟糕的黑客......

Answer 3

您正在寻找的是Set Theory术语中的“补语”。见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

非相交范围VBA

3 个答案: