Difference between two ranges

Question

I can find plenty of questions and example regarding the 'Union' and 'Intersect' VBA methods but I can't find anything much regarding a 'Set Difference' method? Does this exist (other than by using combinations of union and intersect)?.

I'm trying to find a simple way of getting all of range1 excluding any of range1 that overlaps range2 without knowing the size or shape of either range.

Any help would be greatly appreciated.

EDIT.

Attempted solution where rng1 is the red section and rng2 is the blue section (have debugged to check these are correct):

rng = SetDifference(rng, highlightedColumns)

Function SetDifference(Rng1 As Range, Rng2 As Range) As Range
On Error Resume Next
If Application.Intersect(Rng1, Rng2).Address <> Rng2.Address Then
    Exit Function
On Error GoTo 0
Dim aCell As Range
For Each aCell In Rng1
    Dim Result As Range
    If Application.Intersect(aCell, Rng2) Is Nothing Then
        Set Result = Union(Result, aCell)
        End If
    Next aCell
Set SetDifference = Result
End If
End Function

Broad

there is nothing like this pseudocode Range.Difference(Range(A), Range(B)), unfortunately. We need to cope with Union, Intersect, and other properties and instructions. Show what are your ranges (picture) or what you have tried (code) for further support. – Fragrant

So a way of selecting everything in the red range that is not also in the blue range is basically what I'm after - I was hoping there would be a simple concise way to do it like the pseudocode you've posted – Broad

the issue is with three possible attempts to set range.difference. like in your situation- you want to have a) red minus blue, the other one could have b) blue minus red, and final third option is 3) not intersected ranges... did you tried anything, I mean any code? – Fragrant

I found the above solution online and have tried that but it currently gives me error 1004 - application defined or object defined error. Any suggestions? – Broad

call this function with set in front, like: Set rng = SetDifference(rng, highlightedColumns) – Fragrant

That gives me a run-time error 91: Object Variable or With block variable Not set – Broad

I have the same... I'll look into function which you provided. As I said, there are different problems and attitudes here :) – Fragrant

Thanks appreciate the help (again)! – Broad

So, I improved your code a bit and it is working now for test range similar to yours. Give me a feedback please... – Fragrant

Answer 1

Try this function after I have improved it a bit:

Function SetDifference(Rng1 As Range, Rng2 As Range) As Range
On Error Resume Next

If Intersect(Rng1, Rng2) Is Nothing Then
    'if there is no common area then we will set both areas as result
    Set SetDifference = Union(Rng1, Rng2)
    'alternatively
    'set SetDifference = Nothing
    Exit Function
End If

On Error GoTo 0
Dim aCell As Range
For Each aCell In Rng1
    Dim Result As Range
    If Application.Intersect(aCell, Rng2) Is Nothing Then
        If Result Is Nothing Then
            Set Result = aCell
        Else
            Set Result = Union(Result, aCell)
        End If
    End If
Next aCell
Set SetDifference = Result

End Function

Remember to call it like this:

Set Rng = SetDifference(Rng, highlightedColumns)

Fragrant

Answer 2

^Iterating by each cell is very slow for calls like

SetDifference(ActiveSheet.Cells, ActiveSheet.Range("A1")) 'All cells except A1

Therefore:

'(needed by the 2nd function)
Public Function Union(ByRef rng1 As Range, _
                      ByRef rng2 As Range) As Range
    If rng1 Is Nothing Then
        Set Union = rng2
        Exit Function
    End If
    If rng2 Is Nothing Then
        Set Union = rng1
        Exit Function
    End If
    If Not rng1.Worksheet Is rng2.Worksheet Then
        Exit Function
    End If
    Set Union = Application.Union(rng1, rng2)
End Function

Public Function Complement(ByRef rngRangeA As Range, _
                           ByRef rngRangeB As Range) As Range
    Dim rngResult As Range
    Dim rngResultCopy As Range
    Dim rngAreaA As Range
    Dim rngAreaB As Range
    Dim lngX1 As Long
    Dim lngY1 As Long
    Dim lngX2 As Long
    Dim lngY2 As Long
    Dim lngX3 As Long
    Dim lngY3 As Long
    Dim lngX4 As Long
    Dim lngY4 As Long
    Dim lngX5 As Long
    Dim lngY5 As Long
    Dim lngX6 As Long
    Dim lngY6 As Long

    If rngRangeA Is Nothing Then
        Exit Function
    End If
    If rngRangeB Is Nothing Then
        Set Complement = rngRangeA
        Exit Function
    End If
    If Not rngRangeA.Worksheet Is rngRangeB.Worksheet Then
        Set Complement = rngRangeA
        Exit Function
    End If
    Set rngResult = rngRangeA
    With rngRangeA.Worksheet
        For Each rngAreaB In rngRangeB.Areas
            If rngResult Is Nothing Then
                Exit For
            End If
            lngX3 = rngAreaB.Row
            lngY3 = rngAreaB.Column
            lngX4 = lngX3 + rngAreaB.Rows.Count - 1
            lngY4 = lngY3 + rngAreaB.Columns.Count - 1
            Set rngResultCopy = rngResult
            Set rngResult = Nothing
            For Each rngAreaA In rngResultCopy.Areas
                lngX1 = rngAreaA.Row
                lngY1 = rngAreaA.Column
                lngX2 = lngX1 + rngAreaA.Rows.Count - 1
                lngY2 = lngY1 + rngAreaA.Columns.Count - 1
                If lngX3 > lngX1 Then lngX5 = lngX3 Else lngX5 = lngX1
                If lngY3 > lngY1 Then lngY5 = lngY3 Else lngY5 = lngY1
                If lngX4 > lngX2 Then lngX6 = lngX2 Else lngX6 = lngX4
                If lngY4 > lngY2 Then lngY6 = lngY2 Else lngY6 = lngY4
                If lngX5 <= lngX6 And lngY5 <= lngY6 Then
                    If lngX5 > lngX1 Then
                        Set rngResult = Union(rngResult, .Range(.Cells(lngX1, lngY1), .Cells(lngX5 - 1, lngY2)))
                    End If
                    If lngY5 > lngY1 Then
                        Set rngResult = Union(rngResult, .Range(.Cells(lngX5, lngY1), .Cells(lngX6, lngY5 - 1)))
                    End If
                    If lngY2 > lngY6 Then
                        Set rngResult = Union(rngResult, .Range(.Cells(lngX5, lngY6 + 1), .Cells(lngX6, lngY2)))
                    End If
                    If lngX2 > lngX6 Then
                        Set rngResult = Union(rngResult, .Range(.Cells(lngX6 + 1, lngY1), .Cells(lngX2, lngY2)))
                    End If
                Else
                    Set rngResult = Union(rngResult, rngAreaA)
                End If
            Next rngAreaA
        Next rngAreaB
    End With
    Set Complement = rngResult
End Function

Stemson

Answer 3

When ranges have both multiple areas, you will need a different approach. I did not make up the core idea of this example and do not remember where I found this idea (using xlCellTypeConstants). I adapted it to make it work for ranges with areas:

' Range operator that was missing
Public Function rngDifference(rn1 As Range, rn2 As Range) As Range
Dim rnAreaIntersect As Range, varFormulas As Variant
Dim rnAreaS As Range, rnAreaR As Range, rnAreaDiff As Range
Dim rnAreaModified As Range, rnOut As Range
 On Error Resume Next
 Set rngDifference = Nothing
 If rn1 Is Nothing Then Exit Function
 If rn2 Is Nothing Then Set rngDifference = rn1: Exit Function

 Set rnOut = Nothing
 For Each rnAreaS In rn1.Areas
    Set rnAreaModified = rnAreaS

    For Each rnAreaR In rn2.Areas
        Set rnAreaIntersect = Intersect(rnAreaModified, rnAreaR)
        If rnAreaIntersect Is Nothing Then
            Set rnAreaDiff = rnAreaModified
        Else ' there is interesection
            'save
            varFormulas = rnAreaS.Formula

            rnAreaS.Value = 0:  rnAreaIntersect.ClearContents
            If rnAreaS.Cells.Count = 1 Then
               Set rnAreaDiff = Intersect(rnAreaS.SpecialCells(xlCellTypeConstants), rnAreaS)
            Else
               Set rnAreaDiff = rnAreaS.SpecialCells(xlCellTypeConstants)
            End If
            'restore
            rnAreaS.Formula = varFormulas
        End If
        If Not (rnAreaModified Is Nothing) Then
            Set rnAreaModified = Intersect(rnAreaModified, rnAreaDiff)
        End If
    Next
    If Not (rnAreaModified Is Nothing) Then
        If rnOut Is Nothing Then
            Set rnOut = rnAreaModified
        Else
            Set rnOut = Union(rnOut, rnAreaModified)
        End If
    End If
 Next
 Set rngDifference = rnOut
End Function

Hope this helps

Dorladorlisa

Answer 4

This function returns Range R exclusive of Range Ex, which does not have to be on the same worksheet. It includes three methods that depend on conditions:

• Fast -- use a temporary worksheet (credit Tom Ogilvy and Tushar Mehta)
• Quick -- R and Ex are each filled rectangles and Ex is wholly within R
• Slower -- consider each cell

Function Range_Ex(R As Range, Ex As Range) As Range
'
' Return Range R exclusive of Range Ex; Ex does not have to be on R.Worksheet
' Prefer method (fast): Use a temporary worksheet
' Special case (quick): R and Ex are each filled rectangles and Ex is wholly within R
' Last method (slower): Consider each cell
'
' see http://dailydoseofexcel.com/archives/2007/08/17/two-new-range-functions-union-and-subtract/
'
' Aug 2022 by J. Woolley
'
    Dim X As Range, T As Range
    Dim bEV As Boolean, bSU As Boolean, bDA As Boolean
    Dim nRrows As Long, nRcols As Long, nXrows As Long, nXcols As Long
    Dim begXrow As Long, begXcol As Long, endXrow As Long, endXcol As Long
    
    If R Is Nothing Or Ex Is Nothing Then Set Range_Ex = R: Exit Function
    If R.Address = Ex.Address Then Set Range_Ex = Nothing: Exit Function
    Set X = R.Worksheet.Range(Ex.Address)   ' necessary for Intersect and Union
    If Application.Intersect(R, X) Is Nothing Then Set Range_Ex = R: Exit Function
    
    With ActiveWorkbook
        If Not .ProtectStructure Then       ' use a temporary worksheet (fast)
            bSU = Application.ScreenUpdating
            Application.ScreenUpdating = False
            bEV = Application.EnableEvents
            Application.EnableEvents = False
            With .Sheets.Add(Count:=1, Type:=xlWorksheet)
                .Cells.Clear                ' just in case
                .Range(R.Address).Value = 1
                .Range(X.Address).ClearContents
                Set Range_Ex = R.Worksheet.Range(.Cells.SpecialCells(xlCellTypeConstants).Address)
                bDA = Application.DisplayAlerts
                Application.DisplayAlerts = False
                .Delete
                Application.DisplayAlerts = bDA
            End With
            Application.EnableEvents = bEV
            Application.ScreenUpdating = bSU
            Exit Function                   ' done
        End If
    End With
    ' protected workbook; check for special case (quick); otherwise, consider each cell (slower)
    If R.Areas.Count = 1 And X.Areas.Count = 1 And Application.Union(R, X).Address = R.Address Then
        nRrows = R.Rows.Count               ' X is wholly within R (quick)
        nRcols = R.Columns.Count
        nXrows = X.Rows.Count
        nXcols = X.Columns.Count
        begXrow = X.Row - R.Row + 1         ' relative to R
        begXcol = X.Column - R.Column + 1   ' ditto
        endXrow = begXrow + nXrows - 1      ' ditto
        endXcol = begXcol + nXcols - 1      ' ditto
        If begXcol > 1 Then Set T = R.Cells(1, 1).Resize(nRrows, (begXcol - 1)) Else Set T = Nothing
        Set Range_Ex = T
        If endXcol < nRcols Then
            Set T = R.Cells(1, (endXcol + 1)).Resize(nRrows, (nRcols - endXcol))
            GoSub Update
        End If
        If begXrow > 1 Then
            Set T = R.Cells(1, begXcol).Resize((begXrow - 1), nXcols)
            GoSub Update
        End If
        If endXrow < nRrows Then
            Set T = R.Cells((endXrow + 1), begXcol).Resize((nRrows - endXrow), nXcols)
            GoSub Update
        End If
    Else
        For Each T In R                     ' consider each cell (slower)
            If Application.Intersect(T, X) Is Nothing Then GoSub Update
        Next T
    End If
    Exit Function
    
Update:                                     ' use GoSub for common statement
    If Range_Ex Is Nothing Then Set Range_Ex = T Else Set Range_Ex = Application.Union(Range_Ex, T)
    Return
    
End Function

Croom