8

我可以找到很多关于“Union”和“Intersect”VBA 方法的问题和示例，但我找不到关于“Set Difference”方法的任何内容？这是否存在（除了使用联合和相交的组合）？

我试图找到一种简单的方法来获取所有 range1，不包括与 range2 重叠的任何 range1，而不知道任一范围的大小或形状。

任何帮助将不胜感激。

编辑。

在此处输入图像描述

尝试解决方案，其中 rng1 是红色部分， rng2 是蓝色部分（已调试以检查这些是否正确）：

rng = SetDifference(rng, highlightedColumns)

Function SetDifference(Rng1 As Range, Rng2 As Range) As Range
On Error Resume Next
If Application.Intersect(Rng1, Rng2).Address <> Rng2.Address Then
    Exit Function
On Error GoTo 0
Dim aCell As Range
For Each aCell In Rng1
    Dim Result As Range
    If Application.Intersect(aCell, Rng2) Is Nothing Then
        Set Result = Union(Result, aCell)
        End If
    Next aCell
Set SetDifference = Result
End If
End Function
4

3 回答 3

8

在我稍微改进后试试这个功能：

Function SetDifference(Rng1 As Range, Rng2 As Range) As Range
On Error Resume Next

If Intersect(Rng1, Rng2) Is Nothing Then
    'if there is no common area then we will set both areas as result
    Set SetDifference = Union(Rng1, Rng2)
    'alternatively
    'set SetDifference = Nothing
    Exit Function
End If

On Error GoTo 0
Dim aCell As Range
For Each aCell In Rng1
    Dim Result As Range
    If Application.Intersect(aCell, Rng2) Is Nothing Then
        If Result Is Nothing Then
            Set Result = aCell
        Else
            Set Result = Union(Result, aCell)
        End If
    End If
Next aCell
Set SetDifference = Result

End Function

记得这样称呼它：

Set Rng = SetDifference(Rng, highlightedColumns)
于 2013-04-19T07:12:32.057 回答
5

^每个单元格的迭代对于像这样的调用非常慢

SetDifference(ActiveSheet.Cells, ActiveSheet.Range("A1")) '除 A1 以外的所有单元格

所以：

'(needed by the 2nd function)
Public Function Union(ByRef rng1 As Range, _
                      ByRef rng2 As Range) As Range
    If rng1 Is Nothing Then
        Set Union = rng2
        Exit Function
    End If
    If rng2 Is Nothing Then
        Set Union = rng1
        Exit Function
    End If
    If Not rng1.Worksheet Is rng2.Worksheet Then
        Exit Function
    End If
    Set Union = Application.Union(rng1, rng2)
End Function



Public Function Complement(ByRef rngA As Range, _
                           ByRef rngB As Range) As Range
    Dim rngResult As Range
    Dim rngResultCopy As Range
    Dim rngAreaA As Range
    Dim rngAreaB As Range
    Dim lngX1 As Long
    Dim lngY1 As Long
    Dim lngX2 As Long
    Dim lngY2 As Long
    Dim lngX3 As Long
    Dim lngY3 As Long
    Dim lngX4 As Long
    Dim lngY4 As Long
    Dim lngX5 As Long
    Dim lngY5 As Long
    Dim lngX6 As Long
    Dim lngY6 As Long

    If rngA Is Nothing Then
        Exit Function
    End If
    If rngB Is Nothing Then
        Set Complement = rngA
        Exit Function
    End If
    If Not rngA.Worksheet Is rngB.Worksheet Then
        Exit Function
    End If
    Set rngResult = rngA
    With rngA.Worksheet
        For Each rngAreaB In rngB.Areas
            If rngResult Is Nothing Then
                Exit For
            End If
            lngX3 = rngAreaB.Row
            lngY3 = rngAreaB.Column
            lngX4 = lngX3 + rngAreaB.Rows.Count - 1
            lngY4 = lngY3 + rngAreaB.Columns.Count - 1
            Set rngResultCopy = rngResult
            Set rngResult = Nothing
            For Each rngAreaA In rngResultCopy.Areas
                lngX1 = rngAreaA.Row
                lngY1 = rngAreaA.Column
                lngX2 = lngX1 + rngAreaA.Rows.Count - 1
                lngY2 = lngY1 + rngAreaA.Columns.Count - 1
                If lngX3 > lngX1 Then lngX5 = lngX3 Else lngX5 = lngX1
                If lngY3 > lngY1 Then lngY5 = lngY3 Else lngY5 = lngY1
                If lngX4 > lngX2 Then lngX6 = lngX2 Else lngX6 = lngX4
                If lngY4 > lngY2 Then lngY6 = lngY2 Else lngY6 = lngY4
                If lngX5 <= lngX6 And lngY5 <= lngY6 Then
                    If lngX5 > lngX1 Then
                        Set rngResult = Union(rngResult, .Range(.Cells(lngX1, lngY1), .Cells(lngX5 - 1, lngY2)))
                    End If
                    If lngY5 > lngY1 Then
                        Set rngResult = Union(rngResult, .Range(.Cells(lngX5, lngY1), .Cells(lngX6, lngY5 - 1)))
                    End If
                    If lngY2 > lngY6 Then
                        Set rngResult = Union(rngResult, .Range(.Cells(lngX5, lngY6 + 1), .Cells(lngX6, lngY2)))
                    End If
                    If lngX2 > lngX6 Then
                        Set rngResult = Union(rngResult, .Range(.Cells(lngX6 + 1, lngY1), .Cells(lngX2, lngY2)))
                    End If
                Else
                    Set rngResult = Union(rngResult, rngAreaA)
                End If
            Next rngAreaA
        Next rngAreaB
    End With
    Set Complement = rngResult
End Function
于 2013-07-07T07:49:51.547 回答
1

当范围同时具有多个区域时，您将需要不同的方法。我没有编造这个例子的核心思想，也不记得我在哪里找到了这个想法（使用xlCellTypeConstants）。我对其进行了调整以使其适用于具有以下区域的范围：

' Range operator that was missing
Public Function rngDifference(rn1 As Range, rn2 As Range) As Range
Dim rnAreaIntersect As Range, varFormulas As Variant
Dim rnAreaS As Range, rnAreaR As Range, rnAreaDiff As Range
Dim rnAreaModified As Range, rnOut As Range
 On Error Resume Next
 Set rngDifference = Nothing
 If rn1 Is Nothing Then Exit Function
 If rn2 Is Nothing Then Set rngDifference = rn1: Exit Function

 Set rnOut = Nothing
 For Each rnAreaS In rn1.Areas
    Set rnAreaModified = rnAreaS

    For Each rnAreaR In rn2.Areas
        Set rnAreaIntersect = Intersect(rnAreaModified, rnAreaR)
        If rnAreaIntersect Is Nothing Then
            Set rnAreaDiff = rnAreaModified
        Else ' there is interesection
            'save
            varFormulas = rnAreaS.Formula

            rnAreaS.Value = 0:  rnAreaIntersect.ClearContents
            If rnAreaS.Cells.Count = 1 Then
               Set rnAreaDiff = Intersect(rnAreaS.SpecialCells(xlCellTypeConstants), rnAreaS)
            Else
               Set rnAreaDiff = rnAreaS.SpecialCells(xlCellTypeConstants)
            End If
            'restore
            rnAreaS.Formula = varFormulas
        End If
        If Not (rnAreaModified Is Nothing) Then
            Set rnAreaModified = Intersect(rnAreaModified, rnAreaDiff)
        End If
    Next
    If Not (rnAreaModified Is Nothing) Then
        If rnOut Is Nothing Then
            Set rnOut = rnAreaModified
        Else
            Set rnOut = Union(rnOut, rnAreaModified)
        End If
    End If
 Next
 Set rngDifference = rnOut
End Function

希望这可以帮助

于 2017-10-07T01:08:54.687 回答