Thema: Benutzerdefiniere Funktion einer Schaltfläche zuweisen

ClassModule: DieseArbeitsmappe

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   Call CmdDelete
End Sub

Private Sub Workbook_Open()
   Dim oPopUp As CommandBarPopup
   Dim oBtn As CommandBarButton
   Call CmdDelete
   With Application.CommandBars("Worksheet Menu Bar")
      Set oPopUp = .Controls.Add( _
         Type:=msoControlPopup, _
         before:=.Controls.Count, _
         temporary:=True)
   End With
   oPopUp.Caption = "&Kubatur"
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Formel Eingabe"
      .OnAction = "Cbm_Active_Formel"
      .Style = msoButtonCaption
   End With
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Wert Eingabe"
      .OnAction = "Cbm_Active_Wert"
      .Style = msoButtonCaption
   End With
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Formel Auswahl"
      .OnAction = "Cbm_Formel_Select"
      .Style = msoButtonCaption
   End With
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Wert Auswahl"
      .OnAction = "Cbm_Wert_Select"
      .Style = msoButtonCaption
   End With
End Sub

StandardModule: basMain

Function Kubatur(rng As Range) As Double
   Kubatur = rng(1) * rng(2) * rng(3)
End Function

Sub Cbm_Active_Formel()
   Dim iLen As Integer, sRng As String
   With ActiveCell
      If IsEmpty(.Offset(0, -1)) Or .Column < 4 Then
         .Formula = "=kubatur()"
         SendKeys "{F2}{left}"
      Else
         sRng = Range(Cells(.Row, .Column - 3), _
            Cells(.Row, .Column - 1)).Address
         iLen = Len(sRng)
         .Formula = "=kubatur(" & sRng & ")"
            SendKeys "{F2}{left}+{left " & iLen & "}"
      End If
   End With
End Sub

Sub Cbm_Active_Wert()
   Dim iLen As Integer, sRng As String
   With ActiveCell
      If .Column < 4 Then
         Beep
         MsgBox "Die Funktion kann nur ab Spalte D genutzt werden!"
      Else
         ActiveCell.Value = Kubatur(Range(ActiveCell.Offset(0, -3), _
            ActiveCell.Offset(0, -1)))
      End If
   End With
End Sub

Sub Cbm_Formel_Select()
   Dim rng As Range
   Set rng = Application.InputBox("Bereich:", Type:=8)
   If rng.Cells.Count <> 3 Then
      Beep
      MsgBox "Sie benötigen Länge, Breite und Höhe -" & _
         vbLf & "also bitte 3 Zellen auswählen!"
      Exit Sub
   End If
   ActiveCell.Formula = "=kubatur(" & rng.Address & ")"
End Sub

Sub Cbm_Wert_Select()
   Dim rng As Range
   Set rng = Application.InputBox("Bereich:", Type:=8)
   If rng.Cells.Count <> 3 Then
      Beep
      MsgBox "Sie benötigen Länge, Breite und Höhe -" & _
         vbLf & "also bitte 3 Zellen auswählen!"
      Exit Sub
   End If
   ActiveCell.Value = Kubatur(rng)
End Sub

Sub CmdDelete()
   On Error GoTo ERRORHANDLER
   Application.CommandBars("Worksheet Menu Bar") _
      .Controls("&Kubatur").Delete
ERRORHANDLER:
End Sub

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