Non-Intersect Range VBA

Question

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

Answer 1

@as9876 answer (that didn't work for me) inspired me for this simpler solution that only accepts single area ranges (but any number of them) and has no side effects. It builds the complements of each range and utilizes excel to get the union of all complements' intersections with the respective other ranges.

Function NotIntersect(ParamArray theRanges()) As Range
    For Each theRange In theRanges
        Dim theComplement As Range
        Set theComplement = getComplement(theRange)
        For Each theOtherRange In theRanges
            If Not theOtherRange Is theRange Then
                If NotIntersect Is Nothing Then
                    Set NotIntersect = Intersect(theComplement, theOtherRange)
                Else
                    Set theIntersect = Intersect(theComplement, theOtherRange)
                    If Not theIntersect Is Nothing Then Set NotIntersect = Union(NotIntersect, theIntersect)
                End If
            End If
        Next
    Next
End Function

Function getComplement(theRange) As Range
Dim Complements As New Collection
    ' left complement
    If theRange.Column > 1 Then
        Set TopLeftCell_1 = Cells(1, 1)
        Set BottomRightCell_1 = Cells(ActiveSheet.Rows.Count, theRange.Column - 1)
        Complements.Add Range(TopLeftCell_1, BottomRightCell_1)
    End If
    ' upper complement
    If theRange.Row > 1 Then
        Set TopLeftCell_2 = Cells(1, theRange.Column)
        Set BottomRightCell_2 = Cells(theRange.Row - 1, theRange.Column + theRange.Columns.Count - 1)
        Complements.Add Range(TopLeftCell_2, BottomRightCell_2)
    End If
    ' right complement
    If theRange.Column + theRange.Columns.Count < ActiveSheet.Columns.Count Then
        Set TopLeftCell_3 = Cells(1, theRange.Column + theRange.Columns.Count)
        Set BottomRightCell_3 = Cells(ActiveSheet.Rows.Count, ActiveSheet.Columns.Count)
        Complements.Add Range(TopLeftCell_3, BottomRightCell_3)
    End If
    ' bottom complement
    If theRange.Row + theRange.Rows.Count < ActiveSheet.Rows.Count Then
        Set TopLeftCell_4 = Cells(theRange.Row + theRange.Rows.Count, theRange.Column)
        Set BottomRightCell_4 = Cells(ActiveSheet.Rows.Count, theRange.Column + theRange.Columns.Count - 1)
        Complements.Add Range(TopLeftCell_4, BottomRightCell_4)
    End If
    ' build the union of all complements
    For Each c In Complements
        If getComplement Is Nothing Then
            Set getComplement = c
        Else
            Set getComplement = Union(getComplement, c)
        End If
    Next
End Function

Test it with

Sub Test1()
    Debug.Print NotIntersect(Range("$C$1:$D$24"), Range("$A$3:$J$12")).Address = "$A$3:$B$12,$E$3:$J$12,$C$1:$D$2,$C$13:$D$24"
    Debug.Print NotIntersect(Range("$C$3:$D$24"), Range("$A$3:$J$12")).Address = "$A$3:$B$12,$E$3:$J$12,$C$13:$D$24"
    Debug.Print NotIntersect(Range("$C$1:$D$24"), Range("$C$3:$J$12")).Address = "$E$3:$J$12,$C$1:$D$2,$C$13:$D$24"
    Debug.Print NotIntersect(Range("$C$1:$D$12"), Range("$A$3:$J$12")).Address = "$A$3:$B$12,$E$3:$J$12,$C$1:$D$2"
    Debug.Print NotIntersect(Range("$C$1:$D$24"), Range("$A$3:$D$12")).Address = "$A$3:$B$12,$C$1:$D$2,$C$13:$D$24"
    Debug.Print NotIntersect(Range("$C$3:$D$12"), Range("$A$3:$J$12")).Address = "$A$3:$B$12,$E$3:$J$12"
    Debug.Print NotIntersect(Range("$C$1:$D$24"), Range("$C$3:$D$12")).Address = "$C$1:$D$2,$C$13:$D$24"
    Debug.Print NotIntersect(Range("$C$1:$C$24"), Range("$A$3:$J$12")).Address = "$A$3:$B$12,$D$3:$J$12,$C$1:$C$2,$C$13:$C$24"
    Debug.Print NotIntersect(Range("$C$1:$D$24"), Range("$A$3:$J$3")).Address = "$A$3:$B$3,$E$3:$J$3,$C$1:$D$2,$C$4:$D$24"
    Debug.Print NotIntersect(Range("$A$1:$B$12"), Range("$A$3:$B$3")).Address = "$A$1:$B$2,$A$4:$B$12"
    Debug.Print NotIntersect(Range("$A$3:$J$12"), Range("$C$1:$D$24")).Address = "$C$1:$D$2,$C$13:$D$24,$A$3:$B$12,$E$3:$J$12"
    Debug.Print NotIntersect(Range("$A$3:$A$7"), Range("$A$7:$A$9")).Address = "$A$8:$A$9,$A$3:$A$6"
End Sub

Answer 2

I had posted this question to msdn forum with lack of response from SO and got the required solution. I have tested the code and it works fine. I hope it helps.

Here is the link for post on 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

Answer 3

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

Answer 4

As far as I know there is no "clean" function for this. If the requirement "no looping" is important, you could try the following (this is an "approach", not working code):

- 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

I believe each of these can be done without a loop - but it's a terrible hack...