Einfügen Spezial - Tastenkombination und Kontextmenü...

Frage: Einfügen spezial soll über eine Tastenkombination oder über das Kontextmenü ausgeführt werden. Immer mit den Parametern "Werte" und "Leerzellen überspringen".

Special insert to be performed with a keyboard shortcut or via the context menu. Always with the parameters "Values" and "Skip blanks".

Hier noch eine Beispieldatei / Here's a sample file:
Einfügen Spezial - Tastenkombination und Kontextmenü...[XLS 50 KB]

Code gehört in DieseArbeitsmappe / Code is in ThisWorkbook:

Option Explicit
Private Sub Workbook_Open()
    ' Dieser Befehl kann nur genutz werden, wenn das Kontextmenü
    ' NICHT verändet wurde, denn der haut auch eigene Einträge raus.
    ' In dem Fall müsste das Kontextmenü vorher ausgelesen werden
    ' und beim Schliessen (Deaktivieren) der Mappe
    ' wieder eingespielt werden.
    Application.CommandBars("Cell").Reset
    ' Das Kontextmenü wird angepasst
    Context_Menu
    ' Die Tastenkombination "ALT+Q" wird auf ein Makro gelegt
    Application.OnKey "%{q}", "Module1.InsertS"
End Sub
Private Sub Workbook_Activate()
    Application.CommandBars("Cell").Reset
    Context_Menu
    Application.OnKey "%{q}", "Module1.InsertS"
End Sub
Private Sub Workbook_Deactivate()
    ' Die Tastenkombination "ALT+Q" wird auf den Ursprung gesetzt
    Application.OnKey "%{q}"
    Application.CommandBars("Cell").Reset
End Sub

Code gehört in ein Modul / Code is in a module:

' Variablendeklaration erforderlich
Option Explicit
' Public Subs werden im Makrofenster "ALT+F8" NICHT angezeigt
Option Private Module
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : InsertS
' Author    : Case (Ralf Stolzenburg)
' Date      : 16.10.2013
' Purpose   : Einfügen Spezial - Tastenkombination und Kontextmenü...
'--------------------------------------------------------------------------
Sub InsertS()
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' Es gibt nichts zum einfügen - also mach weiter
    On Error Resume Next
    Cells(ActiveCell.Row, ActiveCell.Column).PasteSpecial _
        Paste:=xlPasteValues, SkipBlanks:=True
    ' Schaltet alle Errorhandler aus
    On Error GoTo 0
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
Fin:
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Context_Menu
' Author    : Case (Ralf Stolzenburg)
' Date      : 16.10.2013
' Purpose   : Einfügen Spezial - Tastenkombination und Kontextmenü...
'--------------------------------------------------------------------------
Public Sub Context_Menu()
    ' Variablendeklaration
    Dim objCommandBarButton As CommandBarButton
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Ein neuer temporärer Eintrag im Kontextmenü der Zellen an 6ter Stelle
    Set objCommandBarButton = CommandBars("Cell").Controls.Add(msoControlButton, , , 5, True)
    ' Was soll da stehen und was soll beim draufklicken passieren
    With objCommandBarButton
        .Caption = "Very Special..."
        .OnAction = "InsertS"
    End With
Fin:
    ' Setze die Objektvariable auf Nothing
    Set objCommandBarButton = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...