הדבקה מיוחדת

[bob on fire]

הדבקה מיוחדת

שלום,
האם ניתן להוסיף את הפקודה "הדבקה מיוחדת - > הכפל" לתפריק ההדבקה המהיר שנפתח במקש ימני?

 

[iyyi]

בקובץ המצורף הוספתי את "הכפל" לתפריט העכבר הימני

בקובץ שלך אתה צריך להוסיף לקוד של חוברת העבודה את המקרואים הבאים. מקרו אחד מוסיף את אופציית "הכפל" לתפריט של העכבר הימני. השני מוחק את האופציה ביציאה מהקובץ.

Private Sub Workbook_Deactivate()
    On Error Resume Next
            With Application
                .CommandBars("Cell").Controls("הכפל").Delete
            End With
    On Error GoTo 0
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim cBut As CommandBarButton
    On Error Resume Next
        With Application
            .CommandBars("Cell").Controls("הכפל").Delete
            Set cBut = .CommandBars("Cell").Controls.Add(Temporary:=True)
        End With
        With cBut
           .Caption = "הכפל"
           .Style = msoButtonCaption
           .OnAction = "mult"
           .BeginGroup = True
        End With
    On Error GoTo 0
End Sub

במודול רגיל תוסיף את המקרו הזה שמכפיל את התאים שאתה בוחר בתא שהעתקת. להלן קוד המקרו:

Sub Mult()
    Dim test As String
    Dim clipboard As MSForms.DataObject
    Set clipboard = New MSForms.DataObject
    clipboard.GetFromClipboard
    n = clipboard.GetText * 1
    For Each c In Selection
        c.Value = c.Value * n
    Next
End Sub

דרך השימוש

1. העתק בעזרת Ctrl+C את התא שבו אתה מכפיל את שאר התאים.
2. בחר את תחום התאים שערכם יוכפל.
3. הקש עכבר ימני ובחר למטה ב"הכפל". המספרים בתחום המסומן יוכפלו.

 

[iyyi]

שיפור לקובץ. הצבת "הכפל" בקבוצת אפשרויות ההדבקה

להלן קוד מקרו האירוע המוצמד לחוברת_עבודה_זאת:

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim cBut As CommandBarButton
    On Error Resume Next
        With Application
            .CommandBars("Cell").Controls("הכפל").Delete
            Set cBut = .CommandBars("Cell").Controls.Add(Temporary:=True, Before:=5)
        End With
        With cBut
           .Caption = "הכפל"
           .Style = msoButtonCaption
           .OnAction = "mult"
           .BeginGroup = False
        End With
    On Error GoTo 0
End Sub

 

[bob on fire]

תודה. האם יש דרך להריץ ברמת התוכנה

ולא ברמת הגיליון?
העתקתי את הקוד לפרסונל, אבל זה מגיב רק שם.
אני לא רוצה לשנות את הקבצים האחרים לקבצי אקסל עם מקרו.

 

[iyyi]

שנה את האירועים לפתיחה וסגירת קובץ ע"י הפעולות הבאות:

אתה מוסיף ל"חוברת_עבודה_זאת" ( ThisWorkbook) של קובץ PERSONAL את הקוד הבא:

Private Sub Workbook_Close()
    On Error Resume Next
            With Application
                .CommandBars("Cell").Controls("äëôì").Delete
            End With
    On Error GoTo 0
End Sub

Private Sub Workbook_Open()
Dim cBut As CommandBarButton
    On Error Resume Next
        With Application
            .CommandBars("Cell").Controls("äëôì").Delete
            Set cBut = .CommandBars("Cell").Controls.Add(Temporary:=True, Before:=5)
        End With
        With cBut
           .Caption = "äëôì"
           .Style = msoButtonCaption
           .OnAction = "mult"
           .BeginGroup = False
        End With
    On Error GoTo 0
End Sub

במודול רגיל של קובץ PERSONAL אתה מוסיף את הקוד הבא:

Sub Mult()
On Error GoTo err_trap
    Dim test As String
    Dim clipboard As MSForms.DataObject
    Set clipboard = New MSForms.DataObject
    clipboard.GetFromClipboard
    n = clipboard.GetText * 1
    For Each c In Selection
        c.Value = c.Value * n
    Next
err_trap:
End Sub

שים לב שאתה צריך להוסיף Reference ל- Microsofr Forms 2.0
עשה זאת כך. הוסף UserForm לקובץ PERSONAL ומיד מחק אותו (עכבר ימני ואז Remove). הפעולה הזאת מוסיפה את הדרוש (מצורף צילום מסך)

 

[bob on fire]

עובד מעולה.... תודה רבה!!

הייתי צריך להפעיל את הרפרנס ידנית וזה הסתדר.
&nbsp