Tipp 0543 Aktuelle Zellselektion verändern/bearbeiten
Autor/Einsender:
Datum:
  Alexander Fross
12.08.2009
Entwicklungsumgebung:   Excel 2000
In Excel ist es zuweilen mühsam, wenn man größere nicht zusammenhängende Zellbereiche für die spätere Formatierung selektieren muss. Vertut man sich mit der Maus, muss man die Zellen von Neuem markieren oder die Formatierung in dem zuviel markierten Bereich wieder manuell zurücksetzen. Dieser Tipp bietet verschiedene Funktionen an, mit denen die aktuelle Zellselektion verändert werden kann.
 
Option Explicit
Option Private Module

Public gn_SelIndex              As Long
Public ga_UndoSelRng()          As Range
Public XLS                      As New cls_ChangeSelection
Private Const ms_CMDB_SELECTION As String = _
        "ChangeCurrentSelection"

Public Sub Create_MenuChangeSelection()

  Dim objCmdBar   As CommandBar
  Dim objCmdPopup As CommandBarPopup

  Call Delete_MenuChangeSelection

  'Laufzeitfehler unterdrücken.
  On Error Resume Next

  Set objCmdBar = Application.CommandBars("Worksheet Menu Bar")
  Set objCmdPopup = _
      objCmdBar.Controls.Add(msoControlPopup, , , , True)

  With objCmdPopup
    .BeginGroup = True
    .Caption = "Change Selection"
    .Tag = ms_CMDB_SELECTION

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Undo cell selection"
      .FaceId = 128
      .OnAction = "Get_LastSelection"
      .ShortcutText = "Ctrl+Shift+Z"
      .Style = msoButtonIconAndCaption
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .BeginGroup = True
      .Caption = "Expand to rows"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 1
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Expand to columns"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 2
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Invert selection on selected area"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 3
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Invert selection on used range"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 4
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Invert selection on worksheet"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 5
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .BeginGroup = True
      .Caption = "Customized changes..."
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 6
    End With
  End With

  Application.OnKey "^+{z}", "Get_LastSelection"
  On Error GoTo 0
End Sub

Public Sub Delete_MenuChangeSelection()
  Dim objCmdPopup As CommandBarPopup

  Set objCmdPopup = _
      Application.CommandBars.FindControl(msoControlPopup, , _
      ms_CMDB_SELECTION)

  If Not objCmdPopup Is Nothing Then
    objCmdPopup.Delete
  End If

  Application.OnKey "^+{z}"
End Sub

Private Sub Get_LastSelection()
  Application.EnableEvents = False
  On Error Resume Next

  Do
    Err.Clear

    If gn_SelIndex >= 0 Then
      ga_UndoSelRng(gn_SelIndex).Parent.Parent.Activate
      ga_UndoSelRng(gn_SelIndex).Parent.Activate
      ga_UndoSelRng(gn_SelIndex).Select
      ReDim Preserve ga_UndoSelRng(gn_SelIndex) As Range
      gn_SelIndex = gn_SelIndex - 1
    End If

  Loop Until Err.Number = 0 Or gn_SelIndex <= 1
  On Error GoTo 0

  Application.EnableEvents = True
End Sub

Private Sub Change_CurrentSelection()
  If Application.Workbooks.Count > 0 Then
    If TypeOf Selection Is Range Then
      Select Case CLng(Application.CommandBars.ActionControl.Tag)
        Case 1: Selection.Rows.EntireRow.Select
        Case 2: Selection.Columns.EntireColumn.Select
        Case 3: Call Get_BaseRange(Selection.Cells, 3)
        Case 4: Call Get_BaseRange(Selection.Cells, 4)
        Case 5: Call Get_BaseRange(Selection.Cells, 5)
        Case 6: frm_ChangeSelection.Show
      End Select
    End If
  End If
End Sub

Private Sub Get_BaseRange(ByRef rSelection As Range, ByVal vType _
    As Integer)

  Dim LB(1)   As Long   'Erste Zeile und erste Spalte
  Dim UB(1)   As Long   'Letzte Zeile und letzte Spalte
  Dim objArea As Range  'Einzelne Area Objekte der aktuellen ...
  Dim objRng  As Range  'Gesamter Zellbereich für die Umkehrung ...

  Select Case vType
    Case 5: Set objRng = Cells
    Case 4: Set objRng = ActiveSheet.UsedRange
    Case 3
      LB(0) = Rows.Count
      LB(1) = Columns.Count

      For Each objArea In rSelection.Areas
        With objArea
          If LB(0) > .Rows(1).Row Then LB(0) = .Rows(1).Row
          If LB(1) > .Columns(1).Column Then LB(1) = _
             .Columns(1).Column
          If UB(0) < .Rows(.Rows.Count).Row Then UB(0) = _
             .Rows(.Rows.Count).Row
          If UB(1) < .Columns(1).Column Then UB(1) = _
             .Columns(.Columns.Count).Column
        End With
      Next objArea

      Set objRng = Range(Cells(LB(0), LB(1)), Cells(UB(0), UB(1)))
   End Select

  Call Invert_Selection(objRng, rSelection)
  objRng.Select
End Sub

Public Sub Invert_Selection(ByRef rRngBase As Range, ByRef _
     rRngOld As Range)

  Dim objArea         As Range  'Einzelnes Area Objekt der ...
  Dim objRngUnSel     As Range  'Nicht selektierter Zellbereich ...
  Dim objRng(1 To 4)  As Range  'Erste und letzte Zellen der ...

  If Not rRngOld Is Nothing Then
    'Erste und letzte Zelle der Tabelle in Variable schreiben.
    Set objRng(1) = Cells(1, 1)
    Set objRng(2) = Cells(Cells.Rows.Count, Cells.Columns.Count)

    For Each objArea In rRngOld.Areas
      Set objRng(3) = objArea.Cells(1, objArea.Columns.Count)
      Set objRng(4) = objArea.Cells(objArea.Rows.Count, 1)

      If objRng(1).Row <> objRng(3).Row Then
        Call Join_Rng(objRngUnSel, Range(objRng(1), _
             objRng(3).Rows(0)).EntireRow)
      End If

      If objRng(2).Row <> objRng(4).Row Then
        Call Join_Rng(objRngUnSel, Range(objRng(2), _
             objRng(4).Rows(2)).EntireRow)
      End If

     'Spalten linkes neben dem Area Objekt
      If objRng(1).Column <> objRng(4).Column Then
        Call Join_Rng(objRngUnSel, Range(objRng(1), _
             objRng(4).Columns(0)).EntireColumn)
      End If

     'Spalten rechts neben dem Area Objekt
      If objRng(2).Column <> objRng(3).Column Then
        Call Join_Rng(objRngUnSel, Range(objRng(2),
             objRng(3).Columns(2)).EntireColumn)
      End If

      On Error Resume Next

      Set rRngBase = Application.Intersect(rRngBase, _
          Application.Intersect(objRngUnSel, rRngBase))

      If Err.Number <> 0 Then
        Set rRngBase = ActiveCell
      End If

      On Error GoTo 0
      Set objRngUnSel = Nothing
    Next
  End If
End Sub

Public Sub Join_Rng(ByRef rRngUnSel As Range, _
     ByRef rRngAdd As Range)
  If Not rRngAdd Is Nothing Then
    If Not rRngUnSel Is Nothing Then
      Set rRngUnSel = Union(rRngUnSel, rRngAdd)
    Else
      Set rRngUnSel = rRngAdd
    End If
  End If

End SubOption Explicit
  Option Private Module

  Public gn_SelIndex           As Long
  Public ga_UndoSelRng()       As Range
  Public XLS                   As New cls_ChangeSelection

  Private Const ms_CMDB_SELECTION As String = _
     "ChangeCurrentSelection"

Public Sub Create_MenuChangeSelection()
  Dim objCmdBar   As CommandBar
  Dim objCmdPopup As CommandBarPopup

  Call Delete_MenuChangeSelection
  On Error Resume Next

  Set objCmdBar = Application.CommandBars("Worksheet Menu Bar")
  Set objCmdPopup = _
      objCmdBar.Controls.Add(msoControlPopup, , , , True)

  With objCmdPopup
    .BeginGroup = True
    .Caption = "Change Selection"
    .Tag = ms_CMDB_SELECTION

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Undo cell selection"
      .FaceId = 128
      .OnAction = "Get_LastSelection"
      .ShortcutText = "Ctrl+Shift+Z"
      .Style = msoButtonIconAndCaption
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .BeginGroup = True
      .Caption = "Expand to rows"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 1
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Expand to columns"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 2
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Invert selection on selected area"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 3
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Invert selection on used range"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 4
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .Caption = "Invert selection on worksheet"
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 5
    End With

    With .Controls.Add(msoControlButton, , , , True)
      .BeginGroup = True
      .Caption = "Customized changes..."
      .OnAction = "Change_CurrentSelection"
      .Style = msoButtonIconAndCaption
      .Tag = 6
    End With
  End With

  Application.OnKey "^+{z}", "Get_LastSelection"
  On Error GoTo 0
End Sub

Public Sub Delete_MenuChangeSelection()
  Dim objCmdPopup As CommandBarPopup

  Set objCmdPopup = _
      Application.CommandBars.FindControl(msoControlPopup, , _
      ms_CMDB_SELECTION)

  If Not objCmdPopup Is Nothing Then
    objCmdPopup.Delete
  End If

  Application.OnKey "^+{z}"
End Sub

Private Sub Get_LastSelection()
  Application.EnableEvents = False
  On Error Resume Next

  Do
    Err.Clear

    If gn_SelIndex >= 0 Then
     'Arbeitsmappe der Zell-Selektion aktivieren.
      ga_UndoSelRng(gn_SelIndex).Parent.Parent.Activate
     'Tabelle der Zell-Selektion aktivieren.
      ga_UndoSelRng(gn_SelIndex).Parent.Activate
     'Zellen selektieren.
      ga_UndoSelRng(gn_SelIndex).Select
      ReDim Preserve ga_UndoSelRng(gn_SelIndex) As Range
     'Globaler Index für Selektions-Historie anpassen.
      gn_SelIndex = gn_SelIndex - 1
    End If

  Loop Until Err.Number = 0 Or gn_SelIndex <= 1
  On Error GoTo 0

  Application.EnableEvents = True
End Sub

Private Sub Change_CurrentSelection()
  If Application.Workbooks.Count > 0 Then
    If TypeOf Selection Is Range Then
      Select Case CLng(Application.CommandBars.ActionControl.Tag)
        Case 1: Selection.Rows.EntireRow.Select
        Case 2: Selection.Columns.EntireColumn.Select
        Case 3: Call Get_BaseRange(Selection.Cells, 3)
        Case 4: Call Get_BaseRange(Selection.Cells, 4)
        Case 5: Call Get_BaseRange(Selection.Cells, 5)
        Case 6: frm_ChangeSelection.Show
      End Select
    End If
  End If
End Sub

Private Sub Get_BaseRange(ByRef rSelection As Range, _
   ByVal vType As Integer)

  Dim LB(1)   As Long  'Erste Zeile und erste Spalte
  Dim UB(1)   As Long  'Letzte Zeile und letzte Spalte
  Dim objArea As Range 'Einzelne Area Objekte der aktuellen ...
  Dim objRng  As Range 'Gesamter Zellbereich für die Umkehrung ...

  Select Case vType
    Case 5: Set objRng = Cells
    Case 4: Set objRng = ActiveSheet.UsedRange
    Case 3
      LB(0) = Rows.Count
      LB(1) = Columns.Count

      For Each objArea In rSelection.Areas
        With objArea
          If LB(0) > .Rows(1).Row Then LB(0) = .Rows(1).Row
          If LB(1) > .Columns(1).Column Then LB(1) = _
             .Columns(1).Column
          If UB(0) < .Rows(.Rows.Count).Row Then UB(0) = _
             .Rows(.Rows.Count).Row
          If UB(1) < .Columns(1).Column Then UB(1) = _
             .Columns(.Columns.Count).Column
        End With
      Next objArea

      Set objRng = Range(Cells(LB(0), LB(1)), Cells(UB(0), UB(1)))
  End Select

  Call Invert_Selection(objRng, rSelection)
  objRng.Select
End Sub

Public Sub Invert_Selection(ByRef rRngBase As Range, _
      ByRef rRngOld As Range)

  Dim objArea         As Range  'Einzelnes Area Objekt der ...
  Dim objRngUnSel     As Range  'Nicht selektierter Zellbereich ...
  Dim objRng(1 To 4)  As Range  'Erste und letzte Zellen der ...

  If Not rRngOld Is Nothing Then
    Set objRng(1) = Cells(1, 1)
    Set objRng(2) = Cells(Cells.Rows.Count, Cells.Columns.Count)

    For Each objArea In rRngOld.Areas
      Set objRng(3) = objArea.Cells(1, objArea.Columns.Count)
      Set objRng(4) = objArea.Cells(objArea.Rows.Count, 1)

      If objRng(1).Row <> objRng(3).Row Then
        Call Join_Rng(objRngUnSel, Range(objRng(1), _
             objRng(3).Rows(0)).EntireRow)
      End If

      If objRng(2).Row <> objRng(4).Row Then
        Call Join_Rng(objRngUnSel, Range(objRng(2), _
             objRng(4).Rows(2)).EntireRow)
      End If

      If objRng(1).Column <> objRng(4).Column Then
        Call Join_Rng(objRngUnSel, Range(objRng(1), _
             objRng(4).Columns(0)).EntireColumn)
      End If

      If objRng(2).Column <> objRng(3).Column Then
        Call Join_Rng(objRngUnSel, Range(objRng(2), _
             objRng(3).Columns(2)).EntireColumn)
      End If

      On Error Resume Next

      Set rRngBase = Application.Intersect(rRngBase, _
          Application.Intersect(objRngUnSel, rRngBase))

      If Err.Number <> 0 Then
        Set rRngBase = ActiveCell
      End If

      On Error GoTo 0
      Set objRngUnSel = Nothing
    Next
  End If
End Sub

Public Sub Join_Rng(ByRef rRngUnSel As Range, _
     ByRef rRngAdd As Range)
  If Not rRngAdd Is Nothing Then
    If Not rRngUnSel Is Nothing Then
      Set rRngUnSel = Union(rRngUnSel, rRngAdd)
    Else
      Set rRngUnSel = rRngAdd
    End If
  End If
End Sub
 
Hinweis
Der VBA-Code der im Download befindlichen *.xls-Datei ist vorbildlich dokumentiert.

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
Excel-Version
95
97
2000
2002 (XP)
2003
2007
2010


Download  (56 kB) Downloads bisher: [ 274 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Mittwoch, 10. August 2011