HERBERS Excel-Forum - die Beispiele

Thema: Beispiele zum Thema Sortieren

Home

Gruppe

Allgemein

Problem

In 9 Tabellenblättern werden Beispiele zum Thema Sortieren gezeigt.

Lösung
Geben Sie den Code in ein Standardmodul ein und weisen Sie ihn Schaltflächen zu.
ClassModule: Tabelle1

Private Sub Worksheet_Activate()
   Dim oBtn As CommandBarButton
   With Application.CommandBars("Cell")
      Set oBtn = .FindControl(ID:=21)
      oBtn.Enabled = False
   End With
End Sub

Private Sub Worksheet_Deactivate()
   Application.CommandBars("Cell").Reset
End Sub

StandardModule: Modul1

Sub ReadID()
   Dim sMsg As String
   sMsg = "Erstes Element im Zell-Kontextmenü:" & vbLf
   With Application.CommandBars("Cell").Controls(1)
      sMsg = sMsg & "Caption: " & .Caption & vbLf
      sMsg = sMsg & "ID: " & .ID
      MsgBox sMsg
   End With
End Sub

Sub ShowPosition()
   Dim iLeft As Integer, iTop As Integer
   iLeft = Application.InputBox("Linke Position:", , 200, Type:=1)
   iTop = Application.InputBox("Obere Position:", , 200, Type:=1)
   Application.CommandBars("Cell").ShowPopup iLeft, iTop
End Sub

Sub MonthMessage()
   MsgBox "Aufruf kam von " & _
      Application.CommandBars("Months") _
      .Controls(Application.Caller(1)).Caption
End Sub

Sub SetFilter()
   Dim iRow As Integer
   Application.ScreenUpdating = False
   Rows.Hidden = False
   iRow = 1
   Do Until IsEmpty(Cells(iRow, 1))
      If Weekday(Cells(iRow, 1).Value) <> Application.Caller(1) - 2 Then
         Rows(iRow).Hidden = True
      End If
      iRow = iRow + 1
   Loop
   Application.ScreenUpdating = True
End Sub

Sub ResetFilter()
   Rows.Hidden = False
End Sub

Sub SpaltenAus()
   Selection.EntireColumn.Hidden = True
End Sub

Sub SpaltenEin()
   Selection.EntireColumn.Hidden = False
End Sub

Sub InsertValue()
   ActiveCell.Value = Application.CommandBars("RowValues") _
      .Controls(Application.Caller(1)).Caption
End Sub

Sub SelectSheet()
   Worksheets(Application.CommandBars("SheetSelect") _
      .Controls(Application.Caller(1)).Caption).Select
End Sub

Sub DialogShortCutMenus()
   frmKontext.Show
End Sub

Sub ListShortCutMenus()
   Dim oBar As CommandBar
   Dim oCntr As CommandBarControl
   Dim iRow As Integer
   Application.ScreenUpdating = False
   Workbooks.Add
   Range("A1").Value = "Name"
   Range("B1").Value = "Lokaler Name"
   Range("C1").Value = "Eingebaut"
   Range("D1").Value = "Schaltflächen"
   Range("E1").Value = "ID"
   Rows(1).Font.Bold = True
   iRow = 1
   For Each oBar In Application.CommandBars
      If oBar.Type = msoBarTypePopup Then
         iRow = iRow + 1
         Cells(iRow, 1) = oBar.Name
         Cells(iRow, 2) = oBar.NameLocal
         Cells(iRow, 3) = oBar.BuiltIn
         For Each oCntr In oBar.Controls
            Cells(iRow, 4) = oCntr.Caption
            Cells(iRow, 5) = oCntr.ID
            iRow = iRow + 1
         Next oCntr
      End If
   Next oBar
   Columns.AutoFit
   Application.ScreenUpdating = False
End Sub
ClassModule: frmKontext

Private Sub cboControl_Change()
   If cboControl.Text = "" Then Exit Sub
   lblIndexControl.Caption = _
      Application.CommandBars(cboKontext.Text) _
      .Controls(cboControl.Text).ID
End Sub

Private Sub cboKontext_Change()
   Dim objBar As CommandBar
   Dim objCntr As CommandBarControl
   Set objBar = Application.CommandBars(cboKontext.Text)
   lblIndexMenu.Caption = objBar.Index
   lblNameLocal.Caption = objBar.NameLocal
   cboControl.Clear
   For Each objCntr In objBar.Controls
      cboControl.AddItem objCntr.Caption
   Next objCntr
   cboControl.ListIndex = 0
End Sub

Private Sub cmdCancel_Click()
   Unload Me
End Sub

Private Sub cmdOK_Click()
   Unload Me
   Call ListShortCutMenus
End Sub

Private Sub UserForm_Initialize()
   Dim objBar As CommandBar
   For Each objBar In CommandBars
      If objBar.Type = msoBarTypePopup Then
         cboKontext.AddItem objBar.Name
      End If
   Next objBar
   cboKontext.ListIndex = 0
End Sub
ClassModule: Tabelle3

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   If Not Intersect( _
      Target, Range("A1:F16")) Is Nothing Then
      Cancel = True
   End If
End Sub

ClassModule: Tabelle4

Private Sub Worksheet_Activate()
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim iCounter As Integer
   On Error Resume Next
   Application.CommandBars("Months").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "Months", msoBarPopup, False, True)
   For iCounter = 1 To 12
      Set oBtn = oBar.Controls.Add
      With oBtn
         .Caption = Format( _
            DateSerial(1, iCounter, 1), "mmmm")
         .Style = msoButtonCaption
         .OnAction = "MonthMessage"
      End With
   Next iCounter
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("Months").Delete
   On Error GoTo 0
End Sub

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("Months").ShowPopup
End Sub

ClassModule: Tabelle5

Private Sub Worksheet_Activate()
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim iCounter As Integer
   On Error Resume Next
   Application.CommandBars("Days").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "Days", msoBarPopup, False, True)
   Set oBtn = oBar.Controls.Add
   With oBtn
      .Caption = "Wochentage:"
      .Style = msoButtonCaption
   End With
   For iCounter = 1 To 7
      Set oBtn = oBar.Controls.Add
      With oBtn
         .Caption = Cells(5 + iCounter, 1).Text
         .Style = msoButtonCaption
         .OnAction = "SetFilter"
         If iCounter = 1 Then
            .BeginGroup = True
         End If
      End With
   Next iCounter
   Set oBtn = oBar.Controls.Add
   With oBtn
      .Caption = "Zurücksetzen"
      .Style = msoButtonCaption
      .OnAction = "ResetFilter"
      .BeginGroup = True
   End With
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("Days").Delete
   On Error GoTo 0
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("Days").ShowPopup
End Sub

ClassModule: Tabelle6

Private Sub Worksheet_Activate()
   Dim oBar As CommandBar
   Dim oPopUp As CommandBarPopup
   Dim oCntr As CommandBarControl
   Dim oBtn As CommandBarButton
   On Error Resume Next
   Application.CommandBars("KonNames").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "KonNames", msoBarPopup, False, True)
   Set oPopUp = Application.CommandBars.FindControl(ID:=30023)
   For Each oCntr In oPopUp.Controls
      Set oBtn = oBar.Controls.Add(ID:=oCntr.ID)
   Next oCntr
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("KonNames").Delete
   On Error GoTo 0
End Sub

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("KonNames").ShowPopup
End Sub
ClassModule: Tabelle7

Private Sub Worksheet_Activate()
   Dim oBtn As CommandBarButton
   With Application.CommandBars("Cell")
      On Error Resume Next
      .Controls("Spalten aus").Delete
      .Controls("Spalten ein").Delete
      On Error GoTo 0
      Set oBtn = .Controls.Add
      oBtn.Caption = "Spalten aus"
      oBtn.Style = msoButtonCaption
      oBtn.OnAction = "SpaltenAus"
      oBtn.BeginGroup = True
      Set oBtn = .Controls.Add
      oBtn.Caption = "Spalten ein"
      oBtn.Style = msoButtonCaption
      oBtn.OnAction = "SpaltenEin"
   End With
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   With Application.CommandBars("Cell")
      .Controls("Spalten aus").Delete
      .Controls("Spalten ein").Delete
   End With
   On Error GoTo 0
End Sub

ClassModule: Tabelle8

Private Sub Worksheet_Activate()
   Dim oPopUp As CommandBarControl
   Dim oBtn As CommandBarButton
   On Error Resume Next
   Application.CommandBars("Cell") _
      .Controls("Spalten").Delete
   On Error GoTo 0
   Set oPopUp = Application.CommandBars( _
      "Cell").Controls.Add(msoControlPopup)
   With oPopUp
      .Caption = "Spalten"
      .BeginGroup = True
   End With
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Spalten aus"
      .Style = msoButtonCaption
      .OnAction = "SpaltenAus"
   End With
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Spalten ein"
      .Style = msoButtonCaption
      .OnAction = "SpaltenEin"
   End With
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("Cell") _
      .Controls("Spalten").Delete
   On Error GoTo 0
End Sub

ClassModule: Tabelle9

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim iCol As Integer
   If WorksheetFunction.CountA( _
      Range(Cells(Target.Row, 3), _
      Cells(Target.Row, 256))) = 0 Then Exit Sub
   Cancel = True
   On Error Resume Next
   Application.CommandBars("RowValues").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "RowValues", msoBarPopup)
   For iCol = 3 To 256
      If Not IsEmpty(Cells(Target.Row, iCol)) Then
         Set oBtn = oBar.Controls.Add
         With oBtn
            .Caption = Cells(Target.Row, iCol).Value
            .Style = msoButtonCaption
            .OnAction = "InsertValue"
         End With
      End If
   Next iCol
   Application.CommandBars("RowValues").ShowPopup
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("RowValues").Delete
   On Error GoTo 0
End Sub
ClassModule: Tabelle10

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim wks As Worksheet
   Cancel = True
   On Error Resume Next
   Application.CommandBars("SheetSelect").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "SheetSelect", msoBarPopup)
   For Each wks In Worksheets
      If wks.Index <> Me.Index Then
         Set oBtn = oBar.Controls.Add
         With oBtn
            .Caption = wks.Name
            .Style = msoButtonCaption
            .OnAction = "SelectSheet"
         End With
      End If
   Next wks
   Application.CommandBars("SheetSelect").ShowPopup
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("SheetSelect").Delete
   On Error GoTo 0
End Sub

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Sortieren

Pivot nach "% Differenz von" sortieren Todo-Liste sortieren
mit combobox sortieren Daten aus CSV per Makro sortieren
Zellen aus Liste in Spalten korrekt umsortieren Sporttabelle sortieren
revers sortieren Sortieren mithilfe Excel Makro
Automatisches sortieren mit Hilfe einer Formel Sortieren von Datumswerten in Zelle durch VBA
sortieren mit Zeilen hinzufügen Link ändert sich beim Sortieren
zweidimensionales Array sortieren Zahlenwerte mit QuickSort in Spalte sortieren
Sortieren-Makro erweitern Liste automatisch neu erstellen und umsortieren
ohne Vornamen sortieren Laufzeitfehler beim sortieren
Sortieren Sortieren
Spalte automatisch sortieren per Makro Sortieren einer Tabelle mit VBA
Auslesen und sortieren Überschriften zum Sortieren in Zeile 2
Sortieren auf anderer Tabelle VBA alphabetisch sortieren
Allgemeine Frage zur Fehlerbehandlung allgemeine Fragen zu einer Datenbank
Arbeitsblätter sortieren Fehler bei Umlauten bestimmten Bereich sortieren
Sortieren-Fehler ListBox sortieren
Bei Klick auf Spaltenköpfe Tabelle sortieren per Formel sortieren + andere spalte mitnehmen
Daten mit Excel sammeln und sortieren Sortieren ein Fehler, BITTE nochmal helfen
Daten sortieren Sortieren klappt nicht
Range sortieren - Frage zu Sort Key Jedes 2 Wort umsortieren
Sortieren nach Textinhalt einer Zelle Arbeitsblätter nach Datum sortieren
Daten nach Datum zuordnen/sortieren Daten sortieren, 0 unten anstellen
Rang richtig sortieren Pivot Table nach dem Ergebnis autom. sortieren
ListBox sortieren, trotzdem Daten richtig auslesen Daten nach Import untereinander sortieren
suchen und Sortieren Sortieren