Vba 两个范围之间的差异
我可以找到大量关于“并集”和“交集”VBA方法的问题和示例,但我找不到关于“集差”方法的任何问题和示例?这是否存在(使用并集和交集的组合除外) 我试图找到一种简单的方法来获取所有range1,不包括任何与range2重叠的range1,而不知道任何一个范围的大小或形状 任何帮助都将不胜感激 编辑 尝试的解决方案,其中rng1为红色部分,rng2为蓝色部分(已调试以检查其是否正确):Vba 两个范围之间的差异,vba,excel,set,theory,range,Vba,Excel,Set,Theory,Range,我可以找到大量关于“并集”和“交集”VBA方法的问题和示例,但我找不到关于“集差”方法的任何问题和示例?这是否存在(使用并集和交集的组合除外) 我试图找到一种简单的方法来获取所有range1,不包括任何与range2重叠的range1,而不知道任何一个范围的大小或形状 任何帮助都将不胜感激 编辑 尝试的解决方案,其中rng1为红色部分,rng2为蓝色部分(已调试以检查其是否正确): rng=SetDifference(rng,highlightedColumns) 函数设置差异(Rng1作为范
rng=SetDifference(rng,highlightedColumns)
函数设置差异(Rng1作为范围,Rng2作为范围)作为范围
出错时继续下一步
如果应用程序.Intersect(Rng1,Rng2)。地址Rng2。然后
退出功能
错误转到0
Dim aCell As系列
对于Rng1中的每个aCell
将结果变暗为范围
如果Application.Intersect(aCell,Rng2)什么都不是,那么
设置结果=联合(结果,aCell)
如果结束
下一个亚塞尔
设置SetDifference=结果
如果结束
端函数
在我对该功能稍作改进后,请尝试此功能:
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)
^对于像这样的调用,每个单元格的迭代速度非常慢 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
”(第二个函数需要)
公共功能联合体(ByRef rng1作为范围_
ByRef rng2作为范围)作为范围
如果rng1什么都不是,那么
设置联合=rng2
退出功能
如果结束
如果rng2什么都不是,那么
设置联合=rng1
退出功能
如果结束
如果不是rng1。工作表是rng2。那么
退出功能
如果结束
Set Union=Application.Union(rng1、rng2)
端函数
公共功能补充(ByRef rngA作为范围_
ByRef rngB作为范围)作为范围
Dim rngResult As范围
Dim rngResultCopy As范围
Dim rngAreaA As范围
Dim rngAreaB As范围
变暗lngX1为长
变暗lngY1为长
变暗lngX2为等长
暗lngY2与长lngY2相同
变暗lngX3,长度为
暗lngY3与长lngY3相同
尺寸lngX4与长度相同
暗淡的lngY4和长的一样
变暗lngX5,长度相同
暗长5倍
变暗lngX6,长度相同
暗淡的lngY6和长的一样
如果rngA什么都不是,那么
退出功能
如果结束
如果rngB什么都不是,那么
集合补码=rngA
退出功能
如果结束
如果不是rngA。工作表是rngB。工作表,则
退出功能
如果结束
设置rngResult=rngA
使用rngA.Worksheet
对于rngB.区域中的每个rngAreaB
如果rngResult为空,则
退出
如果结束
lngX3=rngAreaB.行
lngY3=rngAreaB.列
lngX4=lngX3+rngAreaB.Rows.Count-1
lngY4=lngY3+rngAreaB.Columns.Count-1
设置rngResultCopy=rngResult
设置rngResult=Nothing
对于rngResultCopy.区域中的每个rngAreaA
lngX1=rngAreaA.行
lngY1=rngAreaA.列
lngX2=lngX1+rngAreaA.Rows.Count-1
lngY2=lngY1+rngAreaA.Columns.Count-1
如果lngX3>lngX1,则lngX5=lngX3,否则lngX5=lngX1
如果lngY3>lngY1,则lngY5=lngY3,否则lngY5=lngY1
如果lngX4>lngX2,则lngX6=lngX2,否则lngX6=lngX4
如果lngY4>lngY2,则lngY6=lngY2,否则lngY6=lngY4
如果lngX5 lngY1,则
设置rngResult=Union(rngResult,.Range(.Cells(lngX5,lngY1),.Cells(lngX6,lngY5-1)))
如果结束
如果lngY2>lngY6,则
设置rngResult=Union(rngResult,.Range(.Cells(lngX5,lngY6+1),.Cells(lngX6,lngY2)))
如果结束
如果lngX2>lngX6,则
设置rngResult=Union(rngResult,.Range(.Cells(lngX6+1,lngY1),.Cells(lngX2,lngY2)))
如果结束
其他的
设置rngResult=Union(rngResult,rngAreaA)
如果结束
下一个rngAreaA
下一个rngAreaB
以
集合补码=rngResult
端函数
当范围同时具有多个区域时,您将需要不同的方法。我没有想出这个例子的核心思想,也不记得在哪里找到这个思想(使用xlcelltypestants
)。我对其进行了调整,使其适用于以下区域:
' 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
希望这有帮助没有任何东西像这个伪代码
范围。很遗憾,差异(范围(A),范围(B))
。我们需要处理联合
,交叉
,以及其他属性和指令。显示您的范围(图片)或您尝试过的范围(代码)为了获得进一步的支持。因此,选择红色范围内所有不在蓝色范围内的东西的方法基本上就是我想要的-我希望有一种简单简洁的方法,就像您发布的伪代码一样。问题是有三种可能的尝试来设置范围。差异。就像在你的情况下一样-你想要a)红色减去蓝色
,另一个可以有b)蓝色减去红色
,最后第三个选项是3)不相交的范围
。。。你试过什么了吗?我是说代码?我在网上找到了上面的解决方案,并且试过了,但是它现在给我错误1004-应用程序定义的或对象定义的错误。有什么建议吗?用前面的set
调用这个函数,比如:set rng=SetDifference(rng,highlightedColumns)
' 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