Subtracting Ranges

[Jaafar Tribak]

Hi all,

As shown here : Subtracting ranges in VBA (Excel)
I'm trying to write a function to subtract Excel ranges. It should take two input parameters: range A and range B. It should return a range object consisting of cells that are part of range A and are not part of range B.

I am using D_ick Kusleika's recursive function which is really neat and fast but when range B becomes larger, the function takes for ever.

Here is the func from the link above:

Private mrBuild As Range

Public Function SubtractRanges(rFirst As Range, rSecond As Range) As Range

    Dim rInter As Range
    Dim rReturn As Range
    Dim rArea As Range

    Set rInter = Intersect(rFirst, rSecond)
    Set mrBuild = Nothing

    If rInter Is Nothing Then 'No overlap
        Set rReturn = rFirst
    ElseIf rInter.Address = rFirst.Address Then 'total overlap
        Set rReturn = Nothing
    Else 'partial overlap
        For Each rArea In rFirst.Areas
            BuildRange rArea, rInter
        Next rArea
        Set rReturn = mrBuild
    End If

    Set SubtractRanges = rReturn

End Function

Sub BuildRange(rArea As Range, rInter As Range)

    Dim rLeft As Range, rRight As Range
    Dim rTop As Range, rBottom As Range

    If Intersect(rArea, rInter) Is Nothing Then 'no overlap
        If mrBuild Is Nothing Then
            Set mrBuild = rArea
        Else
            Set mrBuild = Union(mrBuild, rArea)
        End If
    Else 'some overlap
        If rArea.Columns.Count = 1 Then 'we've exhausted columns, so split on rows
            If rArea.Rows.Count > 1 Then 'if one cell left, don't do anything
                Set rTop = rArea.Resize(rArea.Rows.Count \ 2) 'split the range top to bottom
                Set rBottom = rArea.Resize(rArea.Rows.Count - rTop.Rows.Count).Offset(rTop.Rows.Count)
                BuildRange rTop, rInter 'rerun it
                BuildRange rBottom, rInter
            End If
        Else
            Set rLeft = rArea.Resize(, rArea.Columns.Count \ 2) 'split the range left to right
            Set rRight = rArea.Resize(, rArea.Columns.Count - rLeft.Columns.Count).Offset(, rLeft.Columns.Count)
            BuildRange rLeft, rInter 'rerun it
            BuildRange rRight, rInter
        End If
    End If

End Sub

Testing:

Sub Test()

    Dim A As Range, B As Range, R As Range
    Dim sngStartTimer As Single
 
    sngStartTimer = Timer
    
    With Sheet1
        Set A = .Cells
        Set B = .Range(.Cells(2, 2), .Cells(100, 100))
    End With
    Set R = SubtractRanges(A, B)
    If Not R Is Nothing Then R.Select

    MsgBox Timer - sngStartTimer

End Sub

Now, as you start increasing the size of the B range, the func becomes slower and slower :

Set B = .Range(.Cells(2, 2), .Cells(100, 100)) '<== Takes 1 secs

Set B = .Range(.Cells(2, 2), .Cells(500, 500)) '<== Takes 9 secs

Set B = .Range(.Cells(2, 2), .Cells(1000, 1000)) '<== Takes 34 secs

I wonder if there is a faster alternative. Thank you.

 

[Jaafar Tribak]

Never mind. The first code worked very well.

 

[Alex Blakenburg]

On a more reasonably sized ranges, using a helper sheet is quit a bit faster.

Sub TestUseHelperSheet()
    Dim sngStartTimer As Single
    sngStartTimer = Timer

    Dim rng1 As Range, rng2 As Range, rng3 As Range
   
    Application.ScreenUpdating = False
    With Sheet1
        Set rng1 = .Cells.Resize(1000)
        Set rng1 = .Range("a1:D10,g50:BD1000")
        Set rng2 = .Range(.Cells(2, 2), .Cells(1000, 1000))
    End With
   
    Sheet2.Range(rng1.Address).Value = 1
    Sheet2.Range(rng2.Address).Value = "#N/A"
   
    Set rng3 = Sheet2.Cells.SpecialCells(xlCellTypeConstants, 1)
    Sheet2.UsedRange.Clear
    Application.ScreenUpdating = True
    Debug.Print rng3.Address
    Debug.Print Timer - sngStartTimer, "AB"
End Sub

 

[Jaafar Tribak]

@Alex Blakenburg
Thanks for answering.
Using a tmp helper sheet is the workaround I was already using. It works fast even when applied to ranges covering the entire sheet. But I recommend that you don't change any cell values in the tmp sheet because that will slow down the function. Instead , I would add CF or better DV to mark the cells and then look for SpecialCells(xlCellTypeAllValidation). This is much faster.

This is the hack I was already using:

Function SubtractRanges(ByVal MinuEndRange As Range, ByVal SubtrahEndRange As Range) As Range

    Dim oTmpWb As Workbook, oTmpSh As Worksheet
    Dim oParentSheet As Worksheet
    Dim sAddr As String
    Dim nSINW As Long
 
    With Application
        nSINW = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1&
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    On Error Resume Next
    If ThisWorkbook.ProtectStructure = False Then
        Set oTmpWb = ThisWorkbook
        Set oTmpSh = oTmpWb.Sheets.Add
    Else
        Set oTmpWb = CreateObject("Excel.Sheet")
        Set oTmpSh = oTmpWb.Sheets(1)
    End If
    Set oParentSheet = MinuEndRange.Worksheet
    Set MinuEndRange = oTmpSh.Range(MinuEndRange.Address)
    Set SubtrahEndRange = oTmpSh.Range(SubtrahEndRange.Address)
    With MinuEndRange
        .Validation.Add Type:=xlValidateCustom, Formula1:="=TRUE"
        SubtrahEndRange.Validation.Delete
        Set SubtractRanges = .SpecialCells(xlCellTypeAllValidation)
    End With
    sAddr = SubtractRanges.Address
    If oTmpSh.Parent Is ThisWorkbook Then
        oTmpSh.Delete
    End If
    If Err.Number = 0& Then
        Set SubtractRanges = oParentSheet.Range(sAddr)
    Else
        Set SubtractRanges = Nothing
    End If
    Application.EnableEvents = True
    Application.SheetsInNewWorkbook = nSINW

End Function

Test -- Function applied to very large ranges:

Sub Test()

    Dim A As Range, B As Range, R As Range
    Dim sngStartTimer As Single
 
    sngStartTimer = Timer
    With Sheet1
        Set A = .Cells
        Set B = .Range(.Cells(2, 2), .Cells(.Rows.Count - 2, .Columns.Count - 2))
        Set R = SubtractRanges(A, B)
        If Not ActiveSheet Is Sheet1 Then
            .Activate
        End If
    End With
    If Not R Is Nothing Then R.Select
    MsgBox Timer - sngStartTimer

End Sub

Yet, the solution in stackoverflow is cleaner as it doesn't involve any tmp worksheets and won't have any issues should the workbook\Worksheet be protected. Adding a tmp sheet on the fly as I did (CreateObject("Excel.Sheet")) would avoid this workbook protection issue but it is still kind of hacky and slightly slower because the workbook will first need to be loaded.

Probably, the only advantage of using the tmp worksheet hack over the solution offered in stackoverflow is when the ranges happen to have merged cells.

Again, thanks Alex for the suggestion.

 

[Alex Blakenburg]

I have to admit I didn't see how setting and deleting validation could be quicker but it definitely is. It also doesn't seem to suffer from the memory issue that I got with changing values where the first range was set to be the whole sheet.
Love your work and thanks for the response.

 

[Artik]

On the Polish forum, master_mix recently posted code that is even faster (by at least order of magnitude compared to SubtractRanges by Jaafar).

Artik

 

[Jaafar Tribak]

On the Polish forum, master_mix recently posted code that is even faster (by at least order of magnitude compared to SubtractRanges by Jaafar).

Artik

Just saw this. Looks like a nice & active excel forum although it is in Polish which I don't understand. It is a shame the forum doesn't permit searching unless you are first registered.

master_mix's code is a bit over complicated but it is fast and most importantly, it doesn't require adding a tmp worksheet.

Thanks for letting us know.