What am i trying to do
I am trying to write a function to subtract Excel ranges . It must take two input parameters: range A and range B. It must return a range object consisting of cells that are part of range A and are not part of range B (as in set subtraction )
What i tried
I saw several examples on the Internet that use a temporary leaflet for this (quickly, but there may be some problems with protected books, etc.) and some other examples that go through the cells through the first range of checking for intersections with the second (very slow) .
After some thought, I came up with this code {1} , which is faster but still slow. Subtracting from a range that represents the entire worksheet takes 1 to 5 minutes, depending on how complex the second range is.
When I looked at this code, trying to find ways to speed it up, I saw the possibility of applying the divide-and-conquer paradigm, which I did {2} . But that made my code slower. I am not very similar to the guy from CS, so I could do something wrong, or this algorithm is simply not the one with which to use divide-and-conquest, I do not know.
I also tried rewriting it using mostly recursion, but left forever or (more often) threw errors from the stack. I did not save the code.
The only (minor) successful improvement I could make was to add the flip switch {3} and go through the rows first, then (in the next call) through the columns instead of going through both in the same call, but the effect was not so good. as I hoped. Now I see that although we are not looking at all the lines in the first call, in the second call we still scroll the same number of lines as in the first, only these lines are a little shorter :)
I would appreciate any help in improving or rewriting this feature, thanks!
Decision based on accepted answer by Dick Kusleika
Dick Kuslayka , thank you very much for providing your answer! I think I will use it with some changes I made:
- Got rid of a global variable (mrBuild)
- The condition of "partial overlap" has been fixed to exclude the case of "no overlap"
- More complex conditions have been added to choose whether to split the range from top to bottom or left to right.
With these changes, the code runs very quickly in most common cases. As already noted, it will still be slow with a huge chessboard-style range, which, I agree, is inevitable.
I think this code still has room for improvement, and I will update this post if I change it.
Improvement options:
- Heuristic for choosing a way to split a range (column or row)
{0} Decision Code
Public Function SubtractRanges(rFirst As Range, rSecond As Range) As Range ' ' Returns a range of cells that are part of rFirst, but not part of rSecond ' (as in set subtraction) ' ' This function handles big input ranges really well! ' ' The reason for having a separate recursive function is ' handling multi-area rFirst 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 Set mrBuild = BuildRange(rArea, rInter) 'recursive Next rArea Set rReturn = mrBuild End If Set SubtractRanges = rReturn End Function Private Function BuildRange(rArea As Range, rInter As Range, _ Optional mrBuild As Range = Nothing) As Range ' ' Recursive function for SubtractRanges() ' ' Subtracts rInter from rArea and adds the result to mrBuild ' Dim rLeft As Range, rRight As Range Dim rTop As Range, rBottom As Range Dim rInterSub As Range Dim GoByColumns As Boolean Set rInterSub = Intersect(rArea, rInter) If rInterSub Is Nothing Then 'no overlap If mrBuild Is Nothing Then Set mrBuild = rArea Else Set mrBuild = Union(mrBuild, rArea) End If ElseIf Not rInterSub.Address = rArea.Address Then 'some overlap If Not rArea.Cells.CountLarge = 1 Then 'just in case there is only one cell for some impossible reason ' Decide whether to go by columns or by rows ' (helps when subtracting whole rows/columns) If Not rInterSub.Columns.Count = rArea.Columns.Count And _ ((Not rInterSub.Cells.CountLarge = 1 And _ (rInterSub.Rows.Count > rInterSub.Columns.Count _ And rArea.Columns.Count > 1) Or (rInterSub.Rows.Count = 1 _ And Not rArea.Columns.Count = 1)) Or _ (rInterSub.Cells.CountLarge = 1 _ And rArea.Columns.Count > rArea.Rows.Count)) Then GoByColumns = True Else GoByColumns = False End If If Not GoByColumns Then 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) Set mrBuild = BuildRange(rTop, rInterSub, mrBuild) 'rerun it Set mrBuild = BuildRange(rBottom, rInterSub, mrBuild) 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) Set mrBuild = BuildRange(rLeft, rInterSub, mrBuild) 'rerun it Set mrBuild = BuildRange(rRight, rInterSub, mrBuild) End If End If End If Set BuildRange = mrBuild End Function
Another code mentioned in the question
{1} Source code (go row, column)
Function SubtractRanges(RangeA, RangeB) As Range ' ' Returns a range of cells that are part of RangeA, but not part of RangeB ' ' This function handles big RangeA pretty well (took less than a minute ' on my computer with RangeA = ActiveSheet.Cells) ' Dim CommonArea As Range Dim Result As Range Set CommonArea = Intersect(RangeA, RangeB) If CommonArea Is Nothing Then Set Result = RangeA ElseIf CommonArea.Address = RangeA.Address Then Set Result = Nothing Else 'a routine to deal with A LOT of cells in RangeA 'go column by column, then row by row Dim GoodCells As Range Dim UnworkedCells As Range For Each Area In RangeA.Areas For Each Row In Area.Rows Set RowCommonArea = Intersect(Row, CommonArea) If Not RowCommonArea Is Nothing Then If Not RowCommonArea.Address = Row.Address Then Set UnworkedCells = AddRanges(UnworkedCells, Row) End If Else Set GoodCells = AddRanges(GoodCells, Row) End If Next Row For Each Column In Area.Columns Set ColumnCommonArea = Intersect(Column, CommonArea) If Not ColumnCommonArea Is Nothing Then If Not ColumnCommonArea.Address = Column.Address Then Set UnworkedCells = AddRanges(UnworkedCells, Column) End If Else Set GoodCells = AddRanges(GoodCells, Column) End If Next Column Next Area If Not UnworkedCells Is Nothing Then For Each Area In UnworkedCells Set GoodCells = AddRanges(GoodCells, SubtractRanges(Area, CommonArea)) Next Area End If Set Result = GoodCells End If Set SubtractRanges = Result End Function
{2} Divide and Win
Function SubtractRanges(RangeA, RangeB) As Range ' ' Returns a range of cells that are part of RangeA, but not part of RangeB ' Dim CommonArea As Range Dim Result As Range Set CommonArea = Intersect(RangeA, RangeB) If CommonArea Is Nothing Then Set Result = RangeA ElseIf CommonArea.Address = RangeA.Address Then Set Result = Nothing Else 'a routine to deal with A LOT of cells in RangeA 'go column by column, then row by row Dim GoodCells As Range Dim UnworkedCells As Range For Each Area In RangeA.Areas RowsNumber = Area.Rows.Count If RowsNumber > 1 Then Set RowsLeft = Range(Area.Rows(1), Area.Rows(RowsNumber / 2)) Set RowsRight = Range(Area.Rows(RowsNumber / 2 + 1), Area.Rows(RowsNumber)) Else Set RowsLeft = Area Set RowsRight = CommonArea.Cells(1, 1) 'the next best thing to Nothing - will end its cycle rather fast and won't throw an error with For Each statement End If For Each Row In Array(RowsLeft, RowsRight) Set RowCommonArea = Intersect(Row, CommonArea) If Not RowCommonArea Is Nothing Then If Not RowCommonArea.Address = Row.Address Then Set UnworkedCells = AddRanges(UnworkedCells, Row) End If Else Set GoodCells = AddRanges(GoodCells, Row) End If Next Row ColumnsNumber = Area.Columns.Count If ColumnsNumber > 1 Then Set ColumnsLeft = Range(Area.Columns(1), Area.Columns(ColumnsNumber / 2)) Set ColumnsRight = Range(Area.Columns(ColumnsNumber / 2 + 1), Area.Columns(ColumnsNumber)) Else Set ColumnsLeft = Area Set ColumnsRight = CommonArea.Cells(1, 1) End If For Each Column In Array(ColumnsLeft, ColumnsRight) Set ColumnCommonArea = Intersect(Column, CommonArea) If Not ColumnCommonArea Is Nothing Then If Not ColumnCommonArea.Address = Column.Address Then Set UnworkedCells = AddRanges(UnworkedCells, Column) End If Else Set GoodCells = AddRanges(GoodCells, Column) End If Next Column Next Area If Not UnworkedCells Is Nothing Then For Each Area In UnworkedCells Set GoodCells = AddRanges(GoodCells, SubtractRanges(Area, CommonArea)) Next Area End If Set Result = GoodCells End If Set SubtractRanges = Result End Function
{3} Source code + flip switch (line by line OR column by column in turn)
Function SubtractRanges(RangeA, RangeB, Optional Flip As Boolean = False) As Range ' ' Returns a range of cells that are part of RangeA, but not part of RangeB ' ' This function handles big RangeA pretty well (took less than a minute ' on my computer with RangeA = ActiveSheet.Cells) ' Dim CommonArea As Range Dim Result As Range Set CommonArea = Intersect(RangeA, RangeB) If CommonArea Is Nothing Then Set Result = RangeA ElseIf CommonArea.Address = RangeA.Address Then Set Result = Nothing Else 'a routine to deal with A LOT of cells in RangeA 'go column by column, then row by row Dim GoodCells As Range Dim UnworkedCells As Range For Each Area In RangeA.Areas If Flip Then For Each Row In Area.Rows Set RowCommonArea = Intersect(Row, CommonArea) If Not RowCommonArea Is Nothing Then If Not RowCommonArea.Address = Row.Address Then Set UnworkedCells = AddRanges(UnworkedCells, Row) End If Else Set GoodCells = AddRanges(GoodCells, Row) End If Next Row Else For Each Column In Area.Columns Set ColumnCommonArea = Intersect(Column, CommonArea) If Not ColumnCommonArea Is Nothing Then If Not ColumnCommonArea.Address = Column.Address Then Set UnworkedCells = AddRanges(UnworkedCells, Column) End If Else Set GoodCells = AddRanges(GoodCells, Column) End If Next Column End If Next Area If Not UnworkedCells Is Nothing Then For Each Area In UnworkedCells Set GoodCells = AddRanges(GoodCells, SubtractRanges(Area, CommonArea, Not Flip)) Next Area End If Set Result = GoodCells End If Set SubtractRanges = Result End Function
A small helper function mentioned here and there:
Function AddRanges(RangeA, RangeB) ' ' The same as Union built-in but handles empty ranges fine. ' If Not RangeA Is Nothing And Not RangeB Is Nothing Then Set AddRanges = Union(RangeA, RangeB) ElseIf RangeA Is Nothing And RangeB Is Nothing Then Set AddRanges = Nothing Else If RangeA Is Nothing Then Set AddRanges = RangeB Else Set AddRanges = RangeA End If End If End Function