Thema: Kontextmenü mit Buchungsvorgaben erstellen

ClassModule: DieseArbeitsmappe

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

ClassModule: Tabelle1

Private Sub Worksheet_Activate()
   Dim oCmdBar As CommandBar
   Dim oPopUp As CommandBarPopup
   Dim oBtn As CommandBarButton
   Dim iRow As Integer
   Call CmdDelete
   Set oCmdBar = Application.CommandBars.Add( _
      Name:="Buchen", Position:=msoBarPopup)
   With Worksheets("Vorgaben")
      For iRow = 1 To WorksheetFunction.CountA(.Columns("B"))
         If Not IsEmpty(.Cells(iRow, 1)) Then
            Set oPopUp = oCmdBar.Controls.Add(msoControlPopup)
            oPopUp.Caption = .Cells(iRow, 1)
         End If
         Set oBtn = oPopUp.Controls.Add
         oBtn.Caption = .Cells(iRow, 2)
         oBtn.OnAction = "Buchen"
         oBtn.Style = msoButtonCaption
      Next iRow
   End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("Buchen").ShowPopup
End Sub

Private Sub Worksheet_Deactivate()
   Call CmdDelete
End Sub

StandardModule: basMain

Sub Buchen()
   Dim rngFind As Range
   Dim intCol As Integer
   If ActiveCell.Column > 3 Then
      Beep
      MsgBox "Sie müssen sich im Spaltenbereich ""A:C"" befinden!"
      Exit Sub
   End If
   With Worksheets("Vorgaben")
      Set rngFind = .Columns(2).Find(CommandBars("Buchen"). _
         Controls(Application.Caller(2)). _
         Controls(Application.Caller(1)).Caption, _
         lookat:=xlWhole, LookIn:=xlValues)
      For intCol = 1 To 3
         Cells(ActiveCell.Row, intCol) = rngFind.Offset(0, intCol - 1)
      Next intCol
   End With
End Sub

Sub CmdDelete()
   On Error GoTo ERRORHANDLER
   Application.CommandBars("Buchen").Delete
ERRORHANDLER:
End Sub

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