Non-Intersect-Bereich VBA

Question

Im folgenden Code rngIntersect.Address gibt A10 zurück. Gibt es einen Weg, wo ich alle Bereiche ohne Kreuzung ohne Schleifen bekommen kann?

Dank

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

Ich hatte diese Frage in msdn Forum mit Mangel an Antwort von SO geschrieben und bekam die erforderliche Lösung. Ich habe den Code getestet und es funktioniert gut. Ich hoffe, es hilft.

Hier ist die link für Post auf 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

Soweit ich weiß, gibt es keine „saubere“ -Funktion dafür ist. Wenn die Anforderung „keine Looping“ wichtig ist, können Sie das folgende versuchen (dies ist ein „Ansatz“, nicht funktionierenden Code):

- 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 

Ich glaube, jeder von ihnen kann ohne eine Schleife durchgeführt werden - aber es ist ein schreckliche hack ...

Answer 3

Was Sie suchen, ist die "Ergänzung" in der Set Theory Terminologie. Siehe Wikipedia. Diese kann durchgeführt werden, ohne durch jede Zelle in beiden Bereichen zu durchlaufen (das wäre ein großer Aufwand für Bereiche mit vielen Zellen), aber Sie müssen jeden Bereich innerhalb des Bereichs Schleife durchlaufen. Diese Schleife ist schnell und effizient. Hier ist der Code:

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 

-Test ist wie folgt:

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