Gruppe
Menue
Problem
Wie kann ich beim Wechsel in ein Buchungsblatt ein Kontextmenü mit Einträgen aus einem Datenblatt erstellen lassen? Nach Auswahl eines Menüpunktes soll der entsprechende Datensatz eingetragen werden.
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