' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub test()
NotIntersect(Range("A1:X100"), Range("B6:B70,D31:D89,F7:F37,G44:G82,I11:I40,I70:I94,K8:K40,K55:K59,L64:L94,M8:U14,P21:X24,N33:V39,Q47:S70,O78:W80,O91:W93")).Select
End Sub
Public Function NotIntersect(Target As Range, Exclude As Range) As Range
'original Code by http://dailydoseofexcel.com/archives/2007/08/17/two-new-range-functions-union-and-subtract/
Dim rng_Temp As Range, rng_New As Range, lngN As Integer, lngM As Integer
On Error Resume Next
If IsObject(Target) And IsObject(Exclude) Then
If Not Target Is Nothing And Not Exclude Is Nothing Then
If TypeOf Target Is Range And TypeOf Exclude Is Range Then
If Not Intersect(Target, Exclude) Is Nothing Then
For lngN = 1 To Target.Areas.Count
Set rng_Temp = removeRange(Target.Areas(lngN), Exclude.Areas(1))
For lngM = 2 To Exclude.Areas.Count
Set rng_Temp = Intersect(rng_Temp, removeRange(Target.Areas(lngN), Exclude.Areas(lngM)))
Next
If rng_New Is Nothing Then Set rng_New = rng_Temp Else Set rng_New = Union(rng_New, rng_Temp)
Next
If Not rng_New Is Nothing Then Set NotIntersect = rng_New
End If
End If
End If
End If
End Function
Private Function removeRange(Target As Range, Exclude As Range) As Range
Dim rng_1 As Range, rng_2 As Range, rng_New As Range, objSh As Worksheet
On Error Resume Next
If Target.Areas.Count > 1 Then Exit Function
If Exclude.Areas.Count > 1 Then Exit Function
If Intersect(Target, Exclude) Is Nothing Then
Set removeRange = Target
Exit Function
End If
Set rng_1 = Intersect(Target, Exclude)
Set objSh = Target.Parent
With objSh
If rng_1.Row > Target.Row Then
Set rng_New = .Range(Target.Rows(1), Target.Rows(rng_1.Row - Target.Row))
End If
If rng_1.Row + rng_1.Rows.Count < Target.Row + Target.Rows.Count Then
Set rng_New = Union(rng_New, .Range(Target.Rows(rng_1.Row - Target.Row + _
rng_1.Rows.Count + 1), Target.Rows(Target.Rows.Count)))
End If
If rng_1.Column > Target.Column Then
Set rng_New = Union(rng_New, .Range(.Cells(rng_1.Row, Target.Column), _
.Cells(rng_1.Row + rng_1.Rows.Count - 1, rng_1.Column - 1)))
End If
If rng_1.Column + rng_1.Columns.Count < Target.Column + Target.Columns.Count Then
Set rng_New = Union(rng_New, .Range(.Cells(rng_1.Row, rng_1.Column + _
rng_1.Columns.Count), .Cells(rng_1.Row + rng_1.Rows.Count - 1, _
Target.Column + Target.Columns.Count - 1)))
End If
End With
If Not rng_New Is Nothing Then Set removeRange = rng_New
End Function