Phạm vi không liên quan VBA

Question

Trong mã bên dưới rngIntersect.Address trả về A10. Có cách nào trong tôi có thể nhận được tất cả các phạm vi không bao gồm giao lộ mà không lặp?

Cảm ơn

Sub NotIntersect() 

    Dim rng As Range, rngVal As Range, rngIntersect As Range 
    Set rng = Range("A1:A10") 
    Set rngVal = Range("A10") 

    Set rngIntersect = Intersect(rng, rngVal) 
    MsgBox rngIntersect.Address 

End Sub 

Answer 1

Tôi đã đăng câu hỏi này lên diễn đàn msdn với sự thiếu phản hồi từ SO và nhận được giải pháp cần thiết. Tôi đã thử nghiệm mã và nó hoạt động tốt. Tôi hy vọng nó sẽ giúp.

Đây là link cho bài đăng trên msdn.

Sub NotIntersect() 
     Dim rng As Range, rngVal As Range, rngDiff As Range 
     Set rng = Range("A1:A10") 
     Set rngVal = Range("A5") 
     Set rngDiff = Difference(rng, rngVal) 
     MsgBox rngDiff.Address 
    End Sub 

    Function Difference(Range1 As Range, Range2 As Range) As Range 
     Dim rngUnion As Range 
     Dim rngIntersect As Range 
     Dim varFormulas As Variant 
     If Range1 Is Nothing Then 
      Set Difference = Range2 
     ElseIf Range1 Is Nothing Then 
      Set Difference = Range1 
     Else 
      Set rngUnion = Union(Range1, Range2) 
      Set rngIntersect = Intersect(Range1, Range2) 
      If rngIntersect Is Nothing Then 
       Set Difference = rngUnion 
      Else 
       varFormulas = rngUnion.Formula 
       rngUnion.Value = 0 
       rngIntersect.ClearContents 
       Set Difference = rngUnion.SpecialCells(xlCellTypeConstants) 
       rngUnion.Formula = varFormulas 
      End If 
     End If 
    End Function 

Answer 2

Theo như tôi biết không có chức năng "sạch" cho việc này. Nếu yêu cầu "không lặp" là rất quan trọng, bạn có thể thử như sau (đây là một "cách tiếp cận", mã không làm việc):

- create a new sheet 
- find intersection of ranges 
- set range from top left to bottom right of intersection to 0 
- set range1 to 1 
- set all values in range2 = XOR of values that are there (so 1 becomes 0, and 0 becomes 1) 
- find all cells with a 1 - their address is the "non-intersection" 
- delete the temp sheet 

Tôi tin rằng mỗi người trong số này có thể được thực hiện mà không có một vòng lặp - nhưng đó là một khủng khiếp hack ...

Answer 3

Điều bạn đang tìm kiếm là "Bổ sung" trong thuật ngữ Tập lý thuyết. Xem Wikipedia. Điều này có thể được thực hiện mà không lặp qua tất cả các ô trong cả hai phạm vi (đó sẽ là một chi phí rất lớn cho phạm vi với nhiều ô), nhưng bạn sẽ cần phải lặp mặc dù mỗi khu vực trong phạm vi. Vòng lặp đó nhanh và hiệu quả. Dưới đây là các mã:

Public Function NotIntersect(Range1 As Range, Range2 As Range) As Range 
Dim NewRange As Range, CurrentArea As Range, CurrentNewArea(1 To 4) As Range, r As Range 
Dim c%, a% 
Dim TopLeftCell(1 To 2) As Range, BottomRightCell(1 To 2) As Range 
Dim NewRanges() As Range, ColNewRanges() As New Collection 
Const N% = 2 
Const U% = 1 

If Range1 Is Nothing And Range2 Is Nothing Then 
    Set NotIntersect = Nothing 
ElseIf Range1.Address = Range2.Address Then 
    Set NotIntersect = Nothing 
ElseIf Range1 Is Nothing Then 
    Set NotIntersect = Range2 
ElseIf Range1 Is Nothing Then 
    Set NotIntersect = Range1 
Else 

    Set TopLeftCell(U) = Range1.Cells(1, 1) 
    Set BottomRightCell(U) = Range1.Cells(Range1.Rows.Count, Range1.Columns.Count) 

    c = Range2.Areas.Count 
    ReDim ColNewRanges(1 To c) 
    ReDim NewRanges(1 To c) 

    For a = 1 To c 
     Set CurrentArea = Range2.Areas(a) 
     Set TopLeftCell(N) = CurrentArea.Cells(1, 1) 
     Set BottomRightCell(N) = CurrentArea.Cells(CurrentArea.Rows.Count, CurrentArea.Columns.Count) 

     On Error Resume Next 
     Set ColNewRanges(a) = New Collection 
     ColNewRanges(a).Add Range(TopLeftCell(U), Cells(TopLeftCell(N).Row - 1, BottomRightCell(U).Column)) 
     ColNewRanges(a).Add Range(Cells(TopLeftCell(N).Row, TopLeftCell(U).Column), Cells(BottomRightCell(N).Row, TopLeftCell(N).Column - 1)) 
     ColNewRanges(a).Add Range(Cells(TopLeftCell(N).Row, BottomRightCell(N).Column + 1), Cells(BottomRightCell(N).Row, BottomRightCell(U).Column)) 
     ColNewRanges(a).Add Range(Cells(BottomRightCell(N).Row + 1, TopLeftCell(U).Column), BottomRightCell(U)) 
     On Error GoTo 0 

     For Each r In ColNewRanges(a) 
      If NewRanges(a) Is Nothing Then 
       Set NewRanges(a) = r 
      Else 
       Set NewRanges(a) = Union(NewRanges(a), r) 
      End If 
     Next r 

    Next a 

    For a = 1 To c 
     If NewRange Is Nothing Then 
      Set NewRange = NewRanges(a) 
     Else 
      Set NewRange = Intersect(NewRange, NewRanges(a)) 
     End If 
    Next a 

    Set NotIntersect = Intersect(Range1, NewRange) 'intersect required in case it's on the bottom or right line, so a part of range will go beyond the line... 

End If  
End Function 

thử nghiệm như sau:

Sub Test1() 
    NotIntersect(Range("$A$1:$N$24"), Range("$G$3:$H$12,$C$4:$D$7,$A$13:$A$15")).Select 
End Sub