问题
I can find plenty of questions and example regarding the 'Union' and 'Intersect' VBA methods but I can't find anything much regarding a 'Set Difference' method? Does this exist (other than by using combinations of union and intersect)?.
I'm trying to find a simple way of getting all of range1 excluding any of range1 that overlaps range2 without knowing the size or shape of either range.
Any help would be greatly appreciated.
EDIT.
Attempted solution where rng1 is the red section and rng2 is the blue section (have debugged to check these are correct):
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
回答1:
Try this function after I have improved it a bit:
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
Remember to call it like this:
Set Rng = SetDifference(Rng, highlightedColumns)
回答2:
^Iterating by each cell is very slow for calls like
SetDifference(ActiveSheet.Cells, ActiveSheet.Range("A1")) 'All cells except A1
Therefore:
'(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
回答3:
When ranges have both multiple areas, you will need a different approach. I did not make up the core idea of this example and do not remember where I found this idea (using xlCellTypeConstants). I adapted it to make it work for ranges with areas:
' 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
Hope this helps
来源：https://stackoverflow.com/questions/16097144/difference-between-two-ranges