Sub prcNamenMenue(Optional blnCreate As Boolean = True)
Dim rngC As Range, cbPOP As CommandBarPopup, cbBTN As CommandBarButton
Const strMenue As String = "Namen einfügen"
On Error Resume Next
CommandBars("Cell").Controls(strMenue).Delete
On Error GoTo 0
If blnCreate = False Then Exit Sub
Set cbPOP = CommandBars("Cell").Controls.Add(msoControlPopup, , , 1, True)
cbPOP.Caption = strMenue
For Each rngC In Sheets("Namen").Columns(1).SpecialCells(xlCellTypeConstants)
Set cbBTN = cbPOP.Controls.Add(msoControlButton, 1)
With cbBTN
.Caption = rngC
.OnAction = "prcInsertName"
.Style = msoButtonCaption
End With
Next
End Sub
Sub prcInsertName()
If Not (ActiveSheet.ProtectContents And ActiveCell.Locked) Then
ActiveCell = CommandBars.ActionControl.Caption
End If
End Sub
Sub prcMenueEin()
prcNamenMenue
End Sub
Sub prcMenueAus()
prcNamenMenue False
End Sub
Klassenmodul Blatt Namen:
Private Sub Worksheet_Change(ByVal Target As Range)
prcNamenMenue
End Sub
In DieseArbeitsmappe:
Private Sub Workbook_Activate()
prcMenueEin
End Sub
Private Sub Workbook_Deactivate()
prcMenueAus
End Sub
Gruß
Rudi