Attribute VB_Name = "Modul1"
Option Base 1


'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr
'Code teilweise von unnötigem Ballast 
'befreit und Variablennamen nach DIN :-)
'durch: Frank Arendt-Theilen

'+++++++++++++++++++++++++++++++++++++++++++++
'+
'+  Zwei Funktionen zur Manipulation
'+  von SELECTIONs:
'+
'+  1. InversSelection
'+     invertiert eine gegebene Selection
'+     in Bezug auf's ganze aktive Arbeitsblatt
'+     z.B. $B$2:$IV$65536
'+     markiere Spalte A und Zeile 1 und
'+     rufe InversSelection auf.
'+
'+  2. DeSelect
'+     entfernt Zellbereiche aus einer zuvor
'+     aktiven ersten Selection
'+     z.B sei ganzes Arbeitsblatt markiert
'+     dann:
'+     a. rufe DeSelect auf
'+     b. markiere Spalte A und Zeile 1
'+     c. rufe DeSelect erneut auf
'+     d. RESULTAT: wie oben
'+                  Selection = $B$2:$IV$65536
'+
'+++++++++++++++++++++++++++++++++++++++++++++




'+++++++++++++++++++++++++++++++++++++++++++++
'+
'+  globale Variablen für die
'+  DeSelect Funktion
'+
'+++++++++++++++++++++++++++++++++++++++++++++

Private dsr As Range
Private rw As Range

'+++++++++++++++++++++++++++++++++++++++++++++
'+
'+  invertiert eine Selection
'+  (bezogen auf das GANZE aktive Arbeitsblatt)
'+
'+++++++++++++++++++++++++++++++++++++++++++++

Public Sub InversSelection()
Dim arrAreas() As String
Dim lngI As Long
Dim rngBereich As Range
  ReDim arrAreas(Selection.Areas.Count)
  For lngI = 1 To UBound(arrAreas)
    arrAreas(lngI) = Selection.Areas(lngI).Address
  Next
  On Error GoTo err_Select
  Set rngBereich = Range(invers_selection(Range(arrAreas(1))))
  For lngI = 2 To UBound(arrAreas)
    Set rngBereich = Intersect(rngBereich, _
    Range(invers_selection(Range(arrAreas(lngI)))))
  Next
  rngBereich.Select
Exit Sub
err_Select:
ActiveCell.Select
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++
'+
'+  interne Funktion zur Bestimmung einer
'+  inversen Selektion eines EINZIGEN
'+  rechteckigen Zellbereiches (einer Area)
'+
'+++++++++++++++++++++++++++++++++++++++++++++

Private Function invers_selection(act_select As Range) As String
On Error Resume Next
Dim part1 As Range
Dim part2 As Range
Dim part3 As Range
Dim part4 As Range
Dim p As Integer
   p = 0
   If act_select.Row > 1 Then
      Set part1 = Rows("1:" & act_select.Row - 1)
      p = 1
   End If
   If act_select.Row + act_select.Rows.Count - 1 < 65536 Then
   Set part2 = Rows(act_select.Row + act_select.Rows.Count & ":65536")
      p = p + 2
   End If
   If act_select.Column > 1 Then
      Set part3 = Range(Columns(1), Columns(act_select.Column - 1))
      p = p + 4
   End If
   If act_select.Column + act_select.Columns.Count - 1 < 256 Then
      Set part4 = Range(Columns(act_select.Column + _
         act_select.Columns.Count), Columns(256))
      p = p + 8
   End If
   invers_selection = ""
   Do While p > 0
   Select Case p
      Case 1, 3, 5, 7, 9, 11, 13, 15:
              If invers_selection = "" Then
                 invers_selection = part1.Address
              Else
     invers_selection = Union(Range(invers_selection), part1).Address
              End If
              p = p - 1
      Case 2, 6, 10, 14:
              If invers_selection = "" Then
                 invers_selection = part2.Address
              Else
      invers_selection = Union(Range(invers_selection), part2).Address
              End If
              p = p - 2
      Case 4, 12:
              If invers_selection = "" Then
                 invers_selection = part3.Address
              Else
      invers_selection = Union(Range(invers_selection), part3).Address
              End If
              p = p - 4
      Case 8:
              If invers_selection = "" Then
                 invers_selection = part4.Address
              Else
      invers_selection = Union(Range(invers_selection), part4).Address
              End If
              p = p - 8
   End Select
   Loop
End Function

'+++++++++++++++++++++++++++++++++++++++++++++
'+
'+  entferne Bereiche aus einer aktiven
'+  Selection
'+  Beim ERSTEN Aufruf der Funktion wird
'+  ein roter Rahmen um die aktive Selection
'+  eingeblendet (NUR im sichtbaren Bereich
'+  des gerade aktiven Fensters!)
'+  Beim ZWEITEN Aufruf wird die dann aktive
'+  Selection von der zuvor rot umrandeten
'+  abgezogen (es wird also die Schnittmenge
'+  gebildet - bezogen auf das GANZE
'+  aktive Arbeitsblatt!)
'+
'+++++++++++++++++++++++++++++++++++++++++++++

Public Sub DeSelect()
On Error Resume Next
If dsr.Cells.Count < 1 Then
  Set dsr = Selection
  Set rw = Intersect(Selection, ActiveWindow.VisibleRange)
  'rote Umrandung der Selection innerhalb Fensterausschnitt!
  rw.BorderAround xlSlantDashDot, xlThick, 3
  ActiveCell.Select
  Else
  InversSelection
  Intersect(dsr, Selection).Select
  rw.Borders.LineStyle = xlNone
  Set dsr = Nothing
  End If
End Sub