VBA（Excel）中的减法范围 我想做什么

我正在尝试编写一个函数来减去Excel范围。它应该有两个输入参数：范围A和范围B。它应该返回一个范围对象，该对象由属于范围A的单元格和不属于范围B的单元格组成（如中所示）

我试过的 我在网上看到过一些使用临时工作表来完成这项工作的例子（速度很快，但可能会引入一些受保护工作簿的问题等），还有一些其他例子是逐单元检查第一个范围与第二个范围的交点（速度非常慢）

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

当我查看代码试图找到使其更快的方法时，我看到了应用分而治之范式的可能性，我做到了{2}。但这反而使我的代码变慢了。我不是一个喜欢CS的人，所以我可能做错了什么，或者这个算法根本不是应该使用分治的算法，我不知道

我也尝试过使用递归重写它，但这需要花费很长时间才能完成，或者（更经常）抛出堆栈外空间错误。我没有保存代码

我所能做的唯一（稍微）成功的改进是添加一个翻转开关{3}，首先遍历行，然后（在下一次调用中）遍历列，而不是在同一次调用中同时遍历两个列，但效果不如我所希望的好。现在我看到，尽管我们在第一次调用中没有遍历所有行，但在第二次调用中，我们仍然循环遍历与第一次调用相同数量的行，只是这些行稍微短一点：）

如果您能帮助我改进或重写此函数，我将不胜感激，谢谢

解决方案，基于 ，非常感谢您提供的答案！我想我会对它进行一些修改：

• 去掉了全局变量（mrBuild）
• 修正了“某些重叠”条件以排除“无重叠”情况
• 添加了更复杂的条件，以选择是从上到下分割范围还是从左到右分割范围

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

我认为这段代码还有改进的余地，如果我修改它，我会更新这篇文章

改进的可能性：

• 选择如何分割范围（按列或按行）的启发式方法

{0}解决方案代码

公共函数减去范围（第一个作为范围，第二个作为范围）作为范围
'
'返回属于rFirst的单元格范围，但不属于rSecond
'（如集合减法）
'
'这个函数可以很好地处理较大的输入范围！
'
'使用单独递归函数的原因是
'处理多区域RFST范围
'
调暗打印机
变暗后转为范围
暗淡的稀有植物
设置rInter=Intersect（第一个，第二个）
设置mrBuild=Nothing
如果rInter为空，则“无重叠”
设置rReturn=rFirst
ElseIf rInter.Address=rFirst.Address然后是“总重叠”
设置返回=无
Else部分重叠
对于第一区域中的每个稀有物种
设置mrBuild=BuildRange（rArea，rInter）递归
下一个稀有物种
设置rReturn=mrBuild
如果结束
设置减法范围=返回
端函数
专用函数BuildRange（rArea作为范围，rInter作为范围_
可选mrBuild As Range=Nothing）As Range
'
'减法范围的递归函数（）
'
'从rArea中减去rInter并将结果添加到mrBuild
'
变光rLeft As范围，变光rLeft As范围
变光rTop作为范围，变光RTOM作为范围
Dim rInterSub As系列
作为布尔值的Dim GoByColumns
设置rInterSub=Intersect（rArea，rInter）
如果rInterSub为空，则“无重叠”
如果mrBuild什么都不是，那么
设置mrBuild=rArea
其他的
设置mrBuild=Union（mrBuild，rArea）
如果结束
ElseIf Not rInterSub.Address=rArea.Address然后“有些重叠”
如果不是rArea.Cells.CountLarge=1，则“以防由于某些不可能的原因只有一个单元格”
'决定是按列还是按行
'（在减去整行/整列时有帮助）
如果不是，则rInterSub.Columns.Count=rArea.Columns.Count和_
（（不是rInterSub.Cells.CountLarge=1和_
（rInterSub.Rows.Count>rInterSub.Columns.Count_
和rArea.Columns.Count>1）或（rInterSub.Rows.Count=1_
而不是rArea.Columns.Count=1）或_
（rInterSub.Cells.CountLarge=1_
然后是rArea.Columns.Count>rArea.Rows.Count）
GoByColumns=True
其他的
GoByColumns=False
如果结束
如果不是GoByColumns，那么
设置rTop=rArea.Resize（rArea.Rows.Count\2）'从上到下拆分范围
Set rbotom=rArea.Resize（rArea.Rows.Count-rTop.Rows.Count）.Offset（rTop.Rows.Count）
设置mrBuild=BuildRange（rTop、rInterSub、mrBuild）'重新运行它
设置mrBuild=BuildRange（RBOTOM、rInterSub、mrBuild）
其他的
设置rLeft=rArea.Resize（，rArea.Columns.Count\2）'从左到右拆分范围
Set rRight=rArea.Resize（，rArea.Columns.Count-rLeft.Columns.Count）.Offset（，rLeft.Columns.Count）
设置mrBuild=BuildRange（rLeft、rInterSub、mrBuild）'重新运行它
设置mrBuild=BuildRange（RRRight、rInterSub、mrBuild）
如果结束
如果结束
如果结束
设置BuildRange=mrBuild
EN
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

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

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

Sub Test()
Dim r As Excel.Range

ActiveSheet.Cells.Clear

Set r = UnionExclusive([A2:C10], [B1:B15])
r.Interior.ColorIndex = 6

Set r = UnionExclusive([F2:H11], [G4:H5,G8:H9,J10:J11,F14:J14])
r.Interior.ColorIndex = 7

Set r = UnionExclusive([F17:J26], [G17:G21,G24:G26,I17:I26,J19:J20])
r.Interior.ColorIndex = 43