减去VBA中的范围(Excel)

Question

减去VBA中的范围(Excel)

SIO*_*SIO 10 excel vba range excel-vba

我想做什么

我正在尝试编写一个函数来减去Excel范围.它应该采用两个输入参数:范围A和范围B.它应该返回一个范围对象,该范围对象由作为范围A的一部分的单元组成,并且不是范围B的一部分(如在set减法中)

我试过的

我在Web上看到一些使用临时工作表来执行此操作的示例(快速,但可能会引入一些受保护工作簿等问题)以及其他一些示例逐个单元格通过第一个范围检查与第二个交叉点的交叉点一个(非常慢).

经过一番思考后,我想出了这个代码{1},它运行得更快,但仍然很慢.从表示整个工作表的范围中减去需要1到5分钟,具体取决于第二个范围的复杂程度.

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

我也尝试使用大多数递归来重写它,但这需要永远完成或(更经常地)抛出了堆栈空间错误.我没有保存代码.

我能够做的唯一(略微)成功的改进是添加一个翻转开关{3}并首先通过行,然后(在下一次调用中)通过列而不是通过同一个调用中的两个,但效果没有我想象的那么好.现在我看到即使我们没有在第一次调用中遍历所有行,在第二次调用中我们仍然循环通过与第一次调用相同的行数,只有这些行有点短:)

感谢您在改进或重写此功能方面的任何帮助,谢谢!

解决方案基于Dick Kusleika接受的答案

Dick Kusleika,非常感谢您提供答案!我想我会通过一些修改来使用它:

摆脱了全局变量(mrBuild)
修复了"一些重叠"的情况,以排除"无重叠"的情况
添加了更复杂的条件,以选择是从上到下还是从左到右分割范围

通过这些修改,代码在大多数常见情况下运行得非常快.正如有人指出的那样,棋盘式的巨大范围仍然会很慢,我同意这是不可避免的.

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

改进可能性:

选择如何分割范围(按列或按行)的启发式方法

{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

Run Code Online (Sandbox Code Playgroud)

问题中提到的其他代码

{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

Run Code Online (Sandbox Code Playgroud)

{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

Run Code Online (Sandbox Code Playgroud)

{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

Run Code Online (Sandbox Code Playgroud)

这里和那里提到一个小助手功能:

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

Run Code Online (Sandbox Code Playgroud)

Answer 1

Dic*_*ika 6

你的分而治之似乎是一个好方法。您需要引入一些递归并且应该相当快

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

Run Code Online (Sandbox Code Playgroud)

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

?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

Run Code Online (Sandbox Code Playgroud)

归档时间：	11 年，9 月前
查看次数：	15813 次
最近记录：	8 年，1 月前