Welcome to OGeek Q&A Community for programmer and developer-Open, Learning and Share
Welcome To Ask or Share your Answers For Others

Categories

0 votes
1.0k views
in Technique[技术] by (71.8m points)

excel - Non-Intersect Range VBA

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
See Question&Answers more detail:os

与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…
Welcome To Ask or Share your Answers For Others

1 Reply

0 votes
by (71.8m points)

What you're looking for is the "Complement" in Set Theory terminology. See Wikipedia. This can be done without looping through every cell in both ranges (that would be a huge overhead for ranges with many cells), but you will need to loop though each Area within the range. That loop is quick and efficient. Here's the code:

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

Test is as follows:

Sub Test1()
    NotIntersect(Range("$A$1:$N$24"), Range("$G$3:$H$12,$C$4:$D$7,$A$13:$A$15")).Select
End Sub

与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…
OGeek|极客中国-欢迎来到极客的世界,一个免费开放的程序员编程交流平台!开放,进步,分享!让技术改变生活,让极客改变未来! Welcome to OGeek Q&A Community for programmer and developer-Open, Learning and Share
Click Here to Ask a Question

...