在VBA中减去范围（Excel）

我正在尝试做什么

我试图写一个函数来减去Excel范围 。 它应该有两个input参数：范围A和范围B.它应该返回范围对象，它是属于范围A的一部分的单元格，不属于范围B的一部分（如在设置减法中 ）

我试过了

我在网上看到了一些使用临时工作表来做这件事的例子（很快，但是可能会引入一些受保护的工作簿等问题） ，还有一些其他的例子，通过第一个范围检查与第二个一个（非常慢） 。

经过一番思考，我已经提出了这个代码{1} ，它运行得更快，但仍然很慢。 从代表整个工作表的范围中减去1到5分钟取决于第二范围的复杂程度。

当我查看那些试图加快速度的代码时，我发现应用分治策略的可能性是我所做的{2} 。 但是这使我的代码变慢了。 我不是一个CS的家伙，所以我可能做错了什么，或者这个algorithm根本就不是分治应该使用的那个，我不知道。

我也尝试使用大多数recursion重写它，但是这花了很长时间来完成或（更经常地）抛出堆栈空间错误。 我没有保存代码。

我已经能够做的唯一（略微）成功的改进是添加一个翻转开关{3} ，首先通过行，然后（在下一个调用中）通过列，而不是通过两个在同一个调用，但效果没有我所希望的那么好。 现在我看到，即使在第一次调用中没有经过所有行，但在第二次调用中，我们仍然会循环执行与第一次调用相同数量的行，但只有这些行稍微短一点:)

我将不胜感激任何帮助改善或重写这个function，谢谢！

该解决scheme基于Dick Kusleika接受的答案

迪克Kusleika ，非常感谢您提供您的答案！ 我想我会用它做一些修改：

• 摆脱了全局variables（mrBuild）
• 修正了“一些重叠”的情况，排除了“不重叠”的情况
• 增加了更复杂的条件来select是从上到下还是从左到右分割范围

通过这些修改，代码在大多数常见情况下运行速度非常快。 正如已经指出的那样，我同意的棋盘式的巨大的范围仍然是缓慢的，是不可避免的。

我认为这个代码还有一个改进的余地，我会更新这个post，以防我修改它。

改进可能性：

• select如何分割范围的启发式（按列或按行）

{0}解决scheme代码

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 

在问题中提到的其他代码

{1}初始代码（逐行，逐列）

 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}分而治之

 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}初始代码+翻转开关（逐行或逐列逐行）

 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 

这里和那里提到一个小帮手function：

 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 

Answer 1

你的分而治之，似乎是一个很好的select。 你需要引入一些recursion，并且应该相当快

 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 

这些不是特别大的范围，但是他们都跑得很快

 ?subtractranges(rangE("A1"),range("a10")).Address $A$1 ?subtractranges(range("a1"),range("a1")) is nothing True ?subtractranges(range("$B$3,$B$6,$C$8:$W$39"),range("a1:C10")).Address $C$11:$C$39,$D$8:$W$39 ?subtractranges(range("a1:C10"),range("$B$3,$B$6,$C$8:$W$39")).Address $A$1:$A$10,$B$1:$B$2,$B$4:$B$5,$B$7:$B$10,$C$1:$C$7 

Answer 2

我的解决scheme更短，但我不知道它是否是最佳的：

 Sub RangeSubtraction() Dim firstRange As Range Dim secondRange As Range Dim rIntersect As Range Dim rOutput As Range Dim x As Range Set firstRange = Range("A1:B10") Set secondRange = Range("A5:B10") Set rIntersect = Intersect(firstRange, secondRange) For Each x In firstRange If Intersect(rIntersect, x) Is Nothing Then If rOutput Is Nothing Then 'ugly 'if-else' but needed, can't use Union(Nothing, Range("A1")) etc. Set rOutput = x Else Set rOutput = Application.Union(rOutput, x) End If End If Next x Msgbox rOutput.Address End Sub 

Answer 3

虽然是迭代的而不是recursion的，但这是我的解决scheme。 该函数返回rangeA减去rangeB

 public Function SubtractRange(rangeA Range, rangeB as Range) as Range 'rangeA is a range to subtract from 'rangeB is the range we want to subtract Dim existingRange As Range Dim resultRange As Range Set existingRange = rangeA Set resultRange = Nothing Dim c As Range For Each c In existingRange If Intersect(c, rangeB) Is Nothing Then If resultRange Is Nothing Then Set resultRange = c Else Set resultRange = Union(c, resultRange) End If End If Next c Set SubtractRange = resultRange End Sub