我正在尝试做什么
我正在尝试编写一个函数来减去 Excel 范围。它应该采用两个输入参数:范围 A 和范围 B。它应该返回一个范围对象，该对象由属于范围 A 且不属于范围 B 的单元格组成(如 set subtraction )
我尝试过的
我在网上看到了一些使用临时工作表来执行此操作的示例(速度很快，但可能会引入 protected 工作簿等问题)以及其他一些逐个单元格的示例通过第一个范围检查与第二个范围的交集(非常慢)。
经过一番思考，我想出了这段代码{1}，它的运行速度更快，但仍然很慢。从代表整个工作表的范围中减去需要 1 到 5 分钟，具体取决于第二个范围的复杂程度。
当我查看该代码并试图找到加快速度的方法时，我发现了应用分而治之范例的可能性，我就这么做了{2}。但这反而使我的代码变慢。我不太懂计算机科学，所以我可能做错了什么，或者这个算法根本不适合使用分治法，我不知道。
我也尝试过主要使用递归来重写它，但这需要很长时间才能完成，或者(更常见的是)抛出堆栈空间错误。我没有保存代码。
我能够做的唯一(勉强)成功的改进是添加翻转开关{3}并首先遍历行，然后(在下一次调用中)遍历列而不是遍历在同一个通话中通过两者，但效果没有我希望的那么好。现在我看到，即使我们没有在第一次调用中遍历所有行，在第二次调用中我们仍然循环遍历与第一次调用相同数量的行，只是这些行稍微短一点:)
如果您能帮助我改进或重写此函数，我将不胜感激，谢谢!
解决方案，基于 Dick Kusleika 接受的答案
Dick Kusleika ，非常感谢您的回答!我想我会在进行一些修改后使用它:
- 摆脱了全局变量(mrBuild)
- 修复了“部分重叠”条件以排除“无重叠”情况
- 添加了更复杂的条件来选择是否从上到下或从左到右分割范围
通过这些修改，代码在大多数常见情况下运行得非常快。正如已经指出的那样，在棋盘式的大范围内它仍然会很慢，我同意这是不可避免的。
我认为这段代码仍有改进的空间，如果我修改它，我会更新这篇文章。
改进的可能性:
- 选择如何分割范围(按列或按行)的启发式
{0}解决方案代码
有车!请参阅下面 SteveS 的回复
Update 2023-07-07
After posting this code to StackOverflow I started using it and hitting its limitations. Fixed version has become significantly more complex and yet it is not perfect, large merged cells may trip it up. Here is the code I've been using for the past 9 years: https://gist.github.com/sio/7423c651d7367de886bb256c4de5e45e
Original buggy version below:
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 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
最佳答案
分而治之似乎是一个不错的方法。您需要引入一些递归并且应该相当快
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
关于vba - VBA (Excel) 中的范围减法，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/21580795/