我正在尝试编写一个函数来减去Excel范围。它应该有两个输入参数：范围A和范围B.它应该返回一个范围对象，该范围对象由作为范围A一部分的单元组成，并且不属于范围B（如set subtraction中所述）
我在网上看到一些使用临时工作表来执行此操作的示例（快速，但可能会引入一些受保护的工作簿等问题）以及其他一些逐个单元格的示例通过第一个范围检查交叉点与第二个（极慢）。
经过一番思考后，我想出了这段代码{1} ，效果更快，但仍然很慢。从代表整个工作表的范围中减去需要1到5分钟，具体取决于第二个范围的复杂程度。
当我查看代码试图找到使其更快的方法时，我看到了应用分而治之范例的可能性，我做了 {2} 。但这使我的代码变慢了。我不是一个CS人，所以我可能做错了，或者这个算法根本就不应该使用分而治之，我不知道。
我还尝试使用大部分递归来重写它，但这需要永远完成或（更经常地）抛出Stack of Space Space错误。我没有保存代码。
我能够做的唯一（略微）成功的改进是添加翻转开关{3} 并首先通过行，然后（在下一次调用中）通过列而不是去通过两个同一个电话，但效果不如我所希望的那么好。现在我看到即使我们没有在第一次调用中遍历所有行，在第二次调用中我们仍然循环通过与第一次调用相同的行数，只有这些行稍微短一些：）< / p>
感谢您在改进或重写此功能方面的任何帮助，谢谢！
Dick Kusleika，非常感谢您提供答案！我想我会通过一些修改来使用它：
通过这些修改，代码在大多数常见情况下运行得非常快。正如有人指出的那样，棋盘式的巨大范围仍然会很慢，我同意这是不可避免的。
我认为此代码仍有改进的余地，如果我修改此代码，我会更新此帖子。
改进可能性：
{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 = 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
答案 0 :(得分：3)
你的分而治之似乎是一种很好的方式。你需要引入一些递归，并且应该相当快
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
答案 1 :(得分：1)
我的解决方案更短但我不知道它是否是最佳解决方案：
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
答案 2 :(得分：0)
虽然是迭代的而不是递归的，但这是我的解决方案。
该函数返回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
答案 3 :(得分：0)
我最近在VBA中编写了一个名为[{1}}的[相当快]函数，该函数返回2个单元格区域之间的 Union –每个范围允许的区域-具有它们共有的单元格范围的 排除 。它实际上仅使用UnionExclusive()和Application.Union()，并且不会循环单个单元格。
[编辑]注意：代码没有还没有[还] 捕获第二范围与多个 first 范围内的时间，例如Application.Intersect() ，因此最好在调用此函数之前进行检查。。
Application.Intersect(r1, r2).AreasCount > 1只需一点点修改，就可以修改代码以排除作为参数传递的第一个范围外部的任何区域。对我来说，需要获得除公共单元以外的所有东西，即与工会相反的东西。
这是一个使用颜色标记显示效果的小测试：
Function UnionExclusive(ByRef r1 As Excel.Range, r2 As Excel.Range) As Excel.Range
'
' This function returns the range of cells that is the Union of both ranges with the
' exclusion of the ranges or cells that they have in common.
'
On Error Resume Next
Dim rngWholeArea As Excel.Range
Dim rngIndividualArea As Excel.Range
Dim rngIntersection As Excel.Range
Dim rngIntersectArea As Excel.Range
Dim rngUnion As Excel.Range
Dim rngSection As Excel.Range
Dim rngResultingRange As Excel.Range
Dim lngWholeTop As Long
Dim lngWholeLeft As Long
Dim lngWholeBottom As Long
Dim lngWholeRight As Long
Dim arrIntersection As Variant
Dim arrWholeArea As Variant
'
' Must be on same sheet, return only first range.
'
If Not r1.Parent Is r2.Parent Then Set UnionExclusive = r1: Exit Function
'
' No overlapping cells, return the union.
'
If Application.Intersect(r1, r2) Is Nothing Then Set UnionExclusive = Application.Union(r1, r2): Exit Function
'
' Range to subtract must be contiguous. If the second range has multiple areas, loop through all the individual areas.
'
If (r2.Areas.Count > 1) _
Then
Set rngResultingRange = r1
For Each rngIndividualArea In r2.Areas
Set rngResultingRange = UnionExclusive(rngResultingRange, rngIndividualArea)
Next rngIndividualArea
Set UnionExclusive = rngResultingRange
Exit Function
End If
'
' Get the overall size of the Union() since Rows/Columns "Count" is based on the first area only.
'
Set rngUnion = Application.Union(r1, r2)
For Each rngIndividualArea In rngUnion.Areas
If (lngWholeTop = 0) Then lngWholeTop = rngIndividualArea.Row Else lngWholeTop = Application.WorksheetFunction.Min(lngWholeTop, rngIndividualArea.Row)
If (lngWholeLeft = 0) Then lngWholeLeft = rngIndividualArea.Column Else lngWholeLeft = Application.WorksheetFunction.Min(lngWholeLeft, rngIndividualArea.Column)
If (lngWholeBottom = 0) Then lngWholeBottom = (rngIndividualArea.Row + rngIndividualArea.Rows.Count - 1) Else lngWholeBottom = Application.WorksheetFunction.Max(lngWholeBottom, (rngIndividualArea.Row + rngIndividualArea.Rows.Count - 1))
If (lngWholeRight = 0) Then lngWholeRight = (rngIndividualArea.Column + rngIndividualArea.Columns.Count - 1) Else lngWholeRight = Application.WorksheetFunction.Max(lngWholeRight, (rngIndividualArea.Column + rngIndividualArea.Columns.Count - 1))
Next rngIndividualArea
arrWholeArea = Array(lngWholeTop, lngWholeLeft, lngWholeBottom, lngWholeRight)
'
' Get the entire area covered by the various areas.
'
Set rngWholeArea = rngUnion.Parent.Range(rngUnion.Parent.Cells(lngWholeTop, lngWholeLeft), rngUnion.Parent.Cells(lngWholeBottom, lngWholeRight))
'
' Get intersection, this is or are the area(s) to remove.
'
Set rngIntersection = Application.Intersect(r1, r2)
For Each rngIntersectArea In rngIntersection.Areas
arrIntersection = Array(rngIntersectArea.Row, _
rngIntersectArea.Column, _
rngIntersectArea.Row + rngIntersectArea.Rows.Count - 1, _
rngIntersectArea.Column + rngIntersectArea.Columns.Count - 1)
'
' Get the difference. This is the whole area above, left, below and right of the intersection.
' Identify if there is anything above the intersection.
'
Set rngSection = Nothing
If (arrWholeArea(0) < arrIntersection(0)) _
Then Set rngSection = Application.Intersect(rngWholeArea.Parent.Range(rngWholeArea.Parent.Cells(arrWholeArea(0), arrWholeArea(1)), _
rngWholeArea.Parent.Cells(arrIntersection(0) - 1, arrWholeArea(3))), _
rngUnion)
If Not rngSection Is Nothing _
Then
If rngResultingRange Is Nothing _
Then Set rngResultingRange = rngSection _
Else Set rngResultingRange = Application.Union(rngResultingRange, rngSection)
End If
'
' Identify if there is anything left of the intersection.
'
Set rngSection = Nothing
If arrWholeArea(1) < arrIntersection(1) _
Then Set rngSection = Application.Intersect(rngWholeArea.Parent.Range(rngWholeArea.Parent.Cells(arrWholeArea(0), arrWholeArea(1)), _
rngWholeArea.Parent.Cells(arrWholeArea(2), arrIntersection(1) - 1)), _
rngUnion)
If Not rngSection Is Nothing _
Then
If rngResultingRange Is Nothing _
Then Set rngResultingRange = rngSection _
Else Set rngResultingRange = Application.Union(rngResultingRange, rngSection)
End If
'
' Identify if there is anything right of the intersection.
'
Set rngSection = Nothing
If arrWholeArea(3) > arrIntersection(3) _
Then Set rngSection = Application.Intersect(rngWholeArea.Parent.Range(rngWholeArea.Parent.Cells(arrWholeArea(0), arrIntersection(3) + 1), _
rngWholeArea.Parent.Cells(arrWholeArea(2), arrWholeArea(3))), _
rngUnion)
If Not rngSection Is Nothing _
Then
If rngResultingRange Is Nothing _
Then Set rngResultingRange = rngSection _
Else Set rngResultingRange = Application.Union(rngResultingRange, rngSection)
End If
'
' Identify if there is anything below the intersection.
'
Set rngSection = Nothing
If arrWholeArea(2) > arrIntersection(2) _
Then Set rngSection = Application.Intersect(rngWholeArea.Parent.Range(rngWholeArea.Parent.Cells(arrIntersection(2) + 1, arrWholeArea(1)), _
rngWholeArea.Parent.Cells(arrWholeArea(2), arrWholeArea(3))), _
rngUnion)
If Not rngSection Is Nothing _
Then
If rngResultingRange Is Nothing _
Then Set rngResultingRange = rngSection _
Else Set rngResultingRange = Application.Union(rngResultingRange, rngSection)
End If
Set rngUnion = rngResultingRange
Set rngResultingRange = Nothing
Next rngIntersectArea
'
' Return the result. This is the area "around" the intersection.
'
Set UnionExclusive = rngUnion
End Function
完整的故事可以在这里找到：https://dutchgemini.wordpress.com/2020/02/28/obtain-a-union-exclusive-range-from-excel-via-vba/
享受。