Подстановка именованного диапазона с другим именованным диапазоном

Question

У меня есть два диапазона rng1 = A1: D10, rng2 = C7: D10, я хочу получить доступ к ячейкам rng1, за исключением C7: D10 в Excel VBA.

Answer 1

Надеется, что это поможет ..

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 2

Не-Союз двух диапазонов рабочих таблиц всегда был проблематичен. Я считаю, что вспомогательная функция помогает изменить методы Union и Intersect.

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 

Результаты Immediate окна VBE в:

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

Answer 3

Мне нравится ответ Jeeped в. Хороший и короткий. Но мне интересно, как это будет зависеть, если размер двух диапазонов будет увеличен. Нажатие функции Union() для каждой ячейки, которую вы хотите сохранить, должно складываться.

Итак, я написал совершенно другое решение, которое не использует функцию Union. Он выполняет только несколько манипуляций с диапазоном независимо от того, насколько велики диапазоны, и вообще нет петли.

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 

О.П. бы назвал это так:

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(p q)-1),o(a:a,,c(p q)-1,r(p q)-1,cs(p q)),o(a:a,,c(p q)+cs(p q)-1,,c(p)),o(a:a,r(p q)+rs(p q)-1,c(p q)-1,r(p),cs(p q)))" 
     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