habe diese SUB (Quelle: HERBER-CD) angepasst bzw. ergänzt.
Private Sub Worksheet_BeforeRightClick( _
ByVal Target As Excel.Range, Cancel As Boolean)
'Quelle: Herber-CD
Dim oBar As CommandBar
Dim oBtn As CommandBarButton
Dim arrItems() As String
Dim arrMenu As Variant
Dim iRow As Integer, iRowM As Integer
Dim wks7 As Worksheet, wks8 As Worksheet
Cancel = True
Call MyContext_Delete 'oder "Application.CommandBars("MyContext").Delete"
Set oBar = CommandBars.Add(Name:="MyContext", Position:=msoBarPopup)
If IsEmpty(Target) Or Selection.Cells.Count > 1 Then Exit Sub
Set wks7 = Worksheets("Abschreibungsarten")
Set wks8 = Worksheets("FIBU")
Select Case Target.Column
Case 7 'AFA-KONTEN
iRow = 2
Do Until IsEmpty(wks7.Cells(iRow, 1))
iRowM = iRowM + 1
ReDim Preserve arrItems(iRowM) 'Redim Preserve erhöht dynamisch arrItems
arrItems(iRowM) = Format(wks7.Cells(iRow, 1), "0000 000") & " " & wks7.Cells(iRow, _
2)
iRow = iRow + 1
Loop
For iRow = 1 To UBound(arrItems)
Set oBtn = oBar.Controls.Add
With oBtn
.Caption = arrItems(iRow)
.OnAction = "ConTextChoiseGet" 'im Modul "ContexMenus_actions"
.Style = msoButtonCaption
End With
Next iRow
oBar.ShowPopup
Case 8 'FIBU-KONTEN
iRow = 2
Do Until IsEmpty(wks8.Cells(iRow, 1))
iRowM = iRowM + 1
ReDim Preserve arrItems(iRowM) 'Redim Preserve erhöht dynamisch arrItems
arrItems(iRowM) = Format(wks8.Cells(iRow, 1), "000 000") & " " & wks8.Cells(iRow, _
2)
iRow = iRow + 1
Loop
For iRow = 1 To UBound(arrItems)
Set oBtn = oBar.Controls.Add
With oBtn
.Caption = arrItems(iRow)
.OnAction = "ConTextChoiseGet" 'im Modul "ContexMenus_actions"
.Style = msoButtonCaption
End With
Next iRow
oBar.ShowPopup
Case Else
Call MyContext_Delete 'oder "Application.CommandBars("MyContext").Delete"
'hier würde ich gerne das Standard-Kontextmenü wieder haben (Ausschneioder, kopieren, _
usw...) aber es erscheint gar nichts? Was sollte hier stehen?
End Select
End Sub
Meine Frage steht nach dem "Case select". Ich hoffe es ist lösbar.mfg
Franz D.