VBA-Programmierung in Microsoft Excel

Tutorial: Excel-Beispiele

Benutzerdefiniere Funktion einer Schaltfläche zuweisen

Gruppe

Menue

Bereich

Button

Thema

Benutzerdefiniere Funktion einer Schaltfläche zuweisen

Problem

Wie kann ich eine benutzerdefinierte Funktion einer Symbolleistenschaltfläche zuweisen? Der Ablauf soll ähnlich sein, wie bei dem Excel-Feature AutoSumme.

Lösung

Geben Sie den Ereigniscode in das Klassenmodul der Arbeitsmappe ein.




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