Gruppe
Menue
Bereich
Context
Thema
Dem Zell-Kontextmenü ein neues Menü hinzufügen
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