在VBA（Excel）中减去范围

本文介绍了在VBA（Excel）中减去范围的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！ 问题描述 29岁程序员，3月因学历无情被辞！ 我正在尝试写一个函数来减去Excel范围。它应该有两个输入参数：范围A和范围B.它应该返回由范围A的一部分组成的范围对象，而不是范围B的一部分（如设置减法）我已经看到一些使用临时工作表来做这个事情的例子（快速但可能会引入一些受保护的工作簿等问题）和/或其他一些例子通过第一个范围单元格进行单元格检查与第二个区域的交叉点（极慢）。I've seen some examples on the web that use a temporary worksheet to do this (fast, but might introduce some issues with protected workbooks and such) and some other examples that go cell by cell through the first range checking for intersections with the second one (extremely slow).经过一些思考，我来了使用此代码{1} ，这可以更快，但仍然很慢。从代表整个工作表的范围中减去需要1到5分钟，具体取决于第二个范围的复杂程度。After some thinking I've come up with this code {1}, which works faster, but still is slow. Subtracting from a range representing the whole worksheet takes from 1 to 5 minutes depending on how complex the second range is.当我查看该代码试图找到方法我看到有可能应用分治征服范例，这是我做的 {2} 。但是这使我的代码变慢了。我不是一个CS的家伙，所以我可能做错了，或者这个算法根本不是应该使用的分治法，我不知道。When I looked over that code trying to find ways to make it faster I saw a possibility for applying the divide-and-conquer paradigm, which I did {2}. But that had made my code slower instead. I'm not much of a CS guy, so I might have done something wrong or this algorithm simply is not the one the divide-and-conquer should be used on, I don't know.我也尝试使用大部分递归来重写它，但是这永远是完成的，（或更频繁地）抛出了堆栈空间错误。我没有保存代码。I have also tried rewriting it using mostly recursion, but that took forever to finish or (more often) had thrown Out of Stack Space errors. I didn't save the code.我已经能够做的唯一（轻微）成功的改进是添加了一个翻转开关{3}The only (marginally) successful improvement I've been able to do is adding a flip switch {3} and going first through rows, then (in the next call) through columns instead of going through both in the same call, but the effect was not as good as I've hoped. Now I see that even though we don't go through all rows in the first call, in the second call we still loop through the same amount of rows we would in the first one, only these rows are a little bit shorter :)感谢您改进或重写此功能的任何帮助，谢谢！I would appreciate any help in improving or rewriting this function, thank you! Dick Kusleika ，非常感谢您提供您的答案！我想我会用它做一些修改：Dick Kusleika, thank you very much for providing your answer! I think I'll use it with some modifications I've made: 摆脱全局变量（mrBuild） 修正某些重叠条件以排除无重叠情况 添加更复杂的条件来选择是否将范围从上到下或从左到右分割通过这些修改，代码在大多数常见情况下运行速度非常快。正如我们已经指出的那样，我认为这是不可避免的棋盘式大范围仍然会很慢。With these modifications the code runs very fast on the most of common cases. As it's been pointed out, it will still be slow with checkerboard-style huge range which I agree is unavoidable.我认为这个代码还有改进的空间，I think this code still has a room for improvement and I'll update this post in case I modify it.改进的可能性： 选择如何拆分范围（按列或行）的启发式 {0}解决方案代码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 = rReturnEnd FunctionPrivate 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 = mrBuildEnd 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 = ResultEnd 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 = ResultEnd 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 = ResultEnd Function一个小帮手功能在这里和那里有一些：A little 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 IfEnd Function推荐答案你的分裂与征服好像是一个好办法。您需要引入一些递归，应该是相当快的Your divide and conquer seems like a good way to go. You need to introduce some recursion and should be reasonably fastPrivate mrBuild As RangePublic 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 = rReturnEnd FunctionSub 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 IfEnd Sub这些不是特别大的范围，但都跑得很快>These aren't particularly huge ranges, but they all ran fast?subtractranges(rangE("A1"),range("a10")).Address$A$1?subtractranges(range("a1"),range("a1")) is nothingTrue?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 这篇关于在VBA（Excel）中减去范围的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！ 上岸，阿里云！