KontextmenueQuell

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim ws As Worksheet
    Dim cell As Range
    Dim cMenu As CommandBar
    Dim cControl As CommandBarControl
    Dim i As Integer

    ' Überprüfen, ob das Arbeitsblatt nicht "Grundinfos" ist
    If Not ThisWorkbook.ActiveSheet.Name = "Grundinfos" Then
        Set ws = ThisWorkbook.Sheets("Grundinfos")

        ' Überprüfen, ob der geklickte Bereich in den gewünschten Zellen liegt
        If Not Intersect(Target, ws.Range("EC72,EC79,EC86,EC93,EC100,EC107,EC114,EC121,EC128,EC135,EC142,EC149,EC156,EC163,EC170,EC177,EC184,EC191,EC198,EC222,EC229,EC236,EC243,EC250,EC257,EC264,EC271,EC278,EC285,EC292,EC299,EC306,EC313,EC320,EC327,EC334,EC341,EC348")) Is Nothing Then
            ' Erstellen Sie das benutzerdefinierte Kontextmenü
            On Error Resume Next
            Application.CommandBars("MyContextMenu").Delete
            On Error GoTo 0
            Set cMenu = Application.CommandBars.Add(Name:="MyContextMenu", Position:=msoBarPopup, MenuBar:=False)

            ' Fügen Sie die Werte V2 bis V26 aus "Grundinfos" als Optionen hinzu
            For i = 2 To 26
                Set cControl = cMenu.Controls.Add(Type:=msoControlButton)
                cControl.Caption = ws.Cells(i, "V").Value
                cControl.Tag = i ' Verknüpfen Sie den Index mit der Position in "Grundinfos"
                cControl.OnAction = "ContextMenuClick" ' Die Prozedur, die aufgerufen wird, wenn auf die Option geklickt wird
            Next i

            ' Positionieren Sie das Kontextmenü neben dem Cursor
            cMenu.ShowPopup
        End If
    End If
End Sub

Sub ContextMenuClick()
    Dim ws As Worksheet
    Dim selectedValue As String
    Dim index As Integer

    Set ws = ThisWorkbook.Sheets("Grundinfos")

    ' Ermitteln Sie den ausgewählten Wert und den zugehörigen Index
    selectedValue = Application.CommandBars.ActionControl.Caption
    index = Application.CommandBars.ActionControl.Tag

    ' Schreiben Sie den Wert aus "Grundinfos" in den Zellbereich W2 bis W26
    ws.Cells(index, "W").Copy
    ThisWorkbook.ActiveSheet.Paste Destination:=ThisWorkbook.ActiveSheet.Range("W2")
    Application.CutCopyMode = False
End Sub