如何捕获通过Excel VBA中的复制/粘贴添加的工作表 [英] How to capture worksheet being added through Copy/Paste in Excel VBA

问题描述

我正在尝试捕获从另一个工作簿复制到工作簿中的工作表.
从另一个工作簿复制工作表时，不会触发Workbook_NewSheet事件. 仅当用户通过(Insert-> Worksheet菜单选项)手动插入它们，或者通过VBA以ThisWorkbook.Worksheets.Add的形式添加新工作表时，才会触发该事件.

I am trying to capture worksheets being copied in to a workbook from another workbook.
Workbook_NewSheet event does not trigger when the sheets are copied from another workbook. It is triggered only if the user manually inserts them through (Insert->Worksheet menu option), or when you add a new sheet through VBA as ThisWorkbook.Worksheets.Add.

我要捕获的基本上是一个粘贴操作，该操作会生成新的工作表.

What I am trying to capture is basically a Paste operation which is resulting in a new sheet.

这可能来自以下任何用户操作:

This might be from any of the below user actions:

1. 用户通过按住Control键(添加新工作表)的方式拖动它来复制现有工作表
2. 用户从另一个工作簿复制工作表
3. 用户将工作表从另一个工作簿中移出

或以下任何VBA代码:

or any of the below VBA code:

SourceWorkbook.Sheets("SourceSheet").Copy Before:=TargetWorkbook.worksheets("SheetNameIn Target") 'copy across workbook'  
SourceWorkbook.Sheets("SourceSheet").Move Before:=TargetWorkbook.worksheets("SheetNameIn Target") 'move across workbook'  
ThisWorkbook. Sheets("SheetName").Copy 'copy within workbook'  

如果您知道在VBA中捕获此操作/宏结果的任何方法，将大有帮助.

If you know any way of capturing this action/macro results within VBA that would be greatly helpful.

请注意，我不想避免这种用户操作(因此我不想保护工作簿)，但是我想以编程方式处理粘贴的工作表以验证数据，如果已经存在类似工作表，请进行更新现有工作表，而不是两张工作表中都有相同的数据.

Please note that I do not want to avoid such an user action (so i do not want to secure the workbook) but I want to handle the pasted sheet programatically to verify the data, and if the similar sheet already exists then update the existing sheet rather than having same data in two sheets.

推荐答案

我隐含的方式是

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
ToggleMenuOptions False, 848, 889
End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
ToggleMenuOptions True, 847, 848, 889
End Sub

Public Function ToggleMenuOptions(bToggle As Boolean, ParamArray ControlID() As Variant) As Boolean
'848 Move or Copy Sheet...
'889 Rename Sheet
'847 Delete Sheet
On Error GoTo lblError
Dim oControl As CommandBarControl, oControls As CommandBarControls, iControl As Integer
If IsMissing(ControlID) Then
    ToggleMenuOptions = False
    Exit Function
End If

For iControl = LBound(ControlID) To UBound(ControlID)
    For Each oControl In Application.CommandBars.FindControls(ID:=ControlID(iControl))
        oControl.Enabled = bToggle
    Next
Next
ToggleMenuOptions = True
Exit Function
lblError:
    If Err.Number Then
        ToggleMenuOptions = False
        Exit Function
    End If
End Function

Private Sub Workbook_NewSheet(ByVal Sh As Object)
MsgBox "Please use Add New Project option in custom Toolbar to add new sheets!!", vbExclamation, "Not Supported"
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End Sub

因此，我的用户将无法重命名，添加或删除工作表.目前，它的运行情况还不错.

So my users wont be able to rename, add or delete sheets. This is working pretty well for now.

这篇关于如何捕获通过Excel VBA中的复制/粘贴添加的工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！