Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Bewerten Sie hier bitte das Excel-Portal

Home Zurück Vor

Download Beispiel-Arbeitsmappe

Thema

Dem Zell-Kontextmenü ein neues Menü hinzufügen

Gruppe

Context

Problem

Solange die Arbeitsmappe geöffnet ist, wird dem Zellkontextmenü ein Menü "Auswahl" hinzugefügt, in dem Summe, Zählen, Mittelwert, Anzahl, Min und Max der Zellauswahl angezeigt werden.

Lösung

Geben Sie den Ereigniscode in die genannten Module der Arbeitsmappe ein.

ClassModule: DieseArbeitsmappe

Dim xlApplication As New clsApp

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   Set xlApplication.xlApp = Nothing
   On Error Resume Next
   Application.CommandBars("Cell").Controls("Auswahl").Delete
   On Error GoTo 0
End Sub

Private Sub Workbook_Open()
   Set xlApplication.xlApp = Application
End Sub

ClassModule: clsApp

Public WithEvents xlApp As Excel.Application

Private Sub xlApp_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
   Dim oPopUp As CommandBarPopup
   Dim oBtn As CommandBarButton
   Dim oFct As WorksheetFunction
   Set oFct = WorksheetFunction
   With Application.CommandBars("Cell")
      On Error Resume Next
      .Controls("Auswahl").Delete
      On Error GoTo 0
      If Selection.Cells.Count = 1 Then Exit Sub
      If WorksheetFunction.Count(Selection) = 0 Then Exit Sub
      Set oPopUp = .Controls.Add(msoControlPopup)
      oPopUp.BeginGroup = True
      Set oBtn = oPopUp.Controls.Add
      With oBtn
         .Caption = "Summe: " & oFct.Sum(Selection)
         .Style = msoButtonCaption
         .OnAction = "CmdCopy"
      End With
      oPopUp.Caption = "Auswahl"
      Set oBtn = oPopUp.Controls.Add
      With oBtn
         .Caption = "Zählen: " & oFct.Count(Selection)
         .Style = msoButtonCaption
         .OnAction = "CmdCopy"
      End With
      Set oBtn = oPopUp.Controls.Add
      With oBtn
         .Caption = "Anzahl: " & oFct.CountA(Selection)
         .Style = msoButtonCaption
         .OnAction = "CmdCopy"
      End With
      Set oBtn = oPopUp.Controls.Add
      With oBtn
         .Caption = "Mittelwert: " & Format(oFct.Average(Selection), "0.00")
         .Style = msoButtonCaption
         .OnAction = "CmdCopy"
      End With
      Set oBtn = oPopUp.Controls.Add
      With oBtn
         .Caption = "Maximalwert: " & oFct.Max(Selection)
         .Style = msoButtonCaption
         .OnAction = "CmdCopy"
      End With
      Set oBtn = oPopUp.Controls.Add
      With oBtn
         .Caption = "Minimalwert: " & oFct.Min(Selection)
         .Style = msoButtonCaption
         .OnAction = "CmdCopy"
      End With
   End With
End Sub

StandardModule: Modul1

Sub CmdCopy()
   Dim ClipAbLage As DataObject
   Dim sTxt As String
   Set ClipAbLage = New DataObject
   sTxt = Application.CommandBars.ActionControl.Caption
   sTxt = Right(sTxt, Len(sTxt) - InStr(sTxt, ": ") - 1)
   ClipAbLage.SetText sTxt
   ClipAbLage.PutInClipboard
End Sub