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

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

Beiträge aus dem Excel-Forum zu den Themen Menue und Context