使用另一个命名的范围来对命名范围进行子集化

我有两个范围rng1 = A1：D10，rng2 = C7：D10，我想在Excel VBA中访问除C7：D10之外的rng1单元格。

Answer 1

我喜欢Jeeped的回答。 很好，很短。 但是我想知道如果这两个范围的大小都增加的话它将会如何。 为每个想要保留的单元格添加联合（）函数必须加起来。

所以我写了一个完全不同的解决scheme，不使用Union函数。 无论范围有多大，它只能进行less量的范围操作，而且根本没有循环。

Public Function Difference(r1 As Range, r2 As Range) As Range Dim r3 As Range, r4 As Range, s$, x&, y&, x1&, x3&, y1& Set r3 = Intersect(r1, r2) '<-- r1 has priority (what we want to keep). If Not r3 Is Nothing Then x3 = r3.Columns.Count x1 = r1.Columns.Count: y1 = r1.Rows.Count x = r3.Column - r1.Column: y = r3.Row - r1.Row With r3.Parent Set r4 = .Range(r1(1, 1), r1(y1, Application.Max(1, x))): If Intersect(r3, r4) Is Nothing Then s = s & "," & r4.Address Set r4 = .Range(r1(1, x + 1), r1(Application.Max(1, y), x + x3)): If Intersect(r3, r4) Is Nothing Then s = s & "," & r4.Address Set r4 = .Range(r1(1, r3.Column + x3 - r1.Column + 1), r1(y1, x1)): If Intersect(r3, r4) Is Nothing Then s = s & "," & r4.Address Set r4 = .Range(r1(y + r3.Rows.Count + 1, x + 1), r1(y1, x + x3)): If Intersect(r3, r4) Is Nothing Then s = s & "," & r4.Address If Len(s) Then Set Difference = .Range(Mid$(s, 2)) End With End If End Function 

OP会这样调用它：

 Public Sub Demo() MsgBox Difference([A1:D10], [C7:D10]).Address End Sub 

UPDATE

@Jeeped我决定结合我们的两种方法。 我认为结果可能是返回距离差异最有效的方法。 如果任何一个范围有多个区域，那么这个例程使用你的方法。 如果两者都是一个块，则使用我的方法。

我重写了我的方法，虽然它仍然是之前的阻塞方法，但是整个构造现在都在一个Evaluate调用中完成。 非常有趣。

 Public Function RangeDiff(p As Range, q As Range) As Range Dim pp$, qq$, r As Range, rng As Range If Not p.Parent Is q.Parent Then Set RangeDiff = p: Exit Function Set r = Intersect(p, q) If r Is Nothing Then Set RangeDiff = p: Exit Function If r.Address = p.Address Then Exit Function If p.Areas.Count = 1 And q.Areas.Count = 1 Then Const F = "p (o(a:a,,,,c(pq)-1),o(a:a,,c(pq)-1,r(pq)-1,cs(pq)),o(a:a,,c(pq)+cs(pq)-1,,c(p)),o(a:a,r(pq)+rs(pq)-1,c(pq)-1,r(p),cs(pq)))" pp = "\" & ChrW$(961): qq = "\" & ChrW$(963) With p.Parent: .Names.Add pp, p: .Names.Add qq, q: End With Set RangeDiff = Evaluate(Replace(Replace(Replace(Replace(Replace(F, "p", pp), "q", qq), "o", "offset"), "c", "column"), "r", "row")) Else For Each r In p If Intersect(r, q) Is Nothing Then If rng Is Nothing Then Set rng = r Else Set rng = Union(rng, r) End If End If Next r Set RangeDiff = rng End If End Function 

Answer 2

希望对你有帮助..

 Sub prac1() Set rng1 = Range("A1:D10") Set rng2 = Range("C7:D10") Dim cell As Range For Each cell In rng1 If Application.Intersect(cell, rng2) Is Nothing Then cell.Value = 10 End If Next End sub 

Answer 3

两个工作表范围的非联合一直是有问题的。 我发现帮助函数有助于扭转联合和相交方法。

 Option Explicit Sub main() Dim r1 As Range, r2 As Range, iWant As Range With Worksheets("Sheet1") Set r1 = .Cells(1, 1).Resize(10, 4) '<~~ Sheet1!A1:D10 Set r2 = .Cells(7, 3).Resize(4, 2) '<~~ Sheet1!C7:D10 Debug.Print r1.Address(0, 0) Debug.Print r2.Address(0, 0) End With Set iWant = whatDoYouWant(r1, r2) Debug.Print iWant.Address(0, 0) 'do something with the iWant range Set iWant = Nothing End Sub Function whatDoYouWant(rKEEP As Range, rOMIT As Range) As Range Dim r As Range, rng As Range For Each r In rKEEP If Intersect(r, rOMIT) Is Nothing Then If rng Is Nothing Then Set rng = r Else Set rng = Union(rng, r) End If End If Next r Set whatDoYouWant = rng End Function 

VBE立即窗口的结果：

 main A1:D10 C7:D10 A1:D6,A7:B10