Gruppe
Menue
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.
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