如何为动态生成的WFH工作表添加Worksheet_Change事件代码？

问题背景 #

我正在制作一个WFH追踪器，包含Home和MasterFile两个主工作表：

• Home工作表的B2单元格用于填写当前日期（每月更新）
• MasterFile为模板工作表

运行NewData宏可复制MasterFile生成两个新工作表：MasterFile + B2日期和WFH + B2日期。其中WFH + B2日期工作表允许编辑，需为该新增工作表自动添加指定的Worksheet_Change事件代码，实现修改单元格时与对应MasterFile + B2日期工作表对比：

• 内容不同则单元格变色为RGB(181,244,0)
• 内容相同则恢复为白色

现有NewData宏代码：

Option Explicit

Sub NewData()

Dim MasterFileWk As Worksheet

Set MasterFileWk = ThisWorkbook.Sheets("MasterFile")

MasterFileWk.Copy after:=Workbooks("WFH tracker.xlsm").Sheets(Workbooks("WFH tracker.xlsm").Worksheets.Count)

ActiveSheet.Name = "MasterFile " & ThisWorkbook.Sheets("Home").Range("B2")

'second copy
MasterFileWk.Copy after:=Workbooks("WFH tracker.xlsm").Sheets(Workbooks("WFH tracker.xlsm").Worksheets.Count)
ActiveSheet.Name = "WFH " & ThisWorkbook.Sheets("Home").Range("B2")

On Error Resume Next

ThisWorkbook.Sheets("MasterFile " & ThisWorkbook.Sheets("Home").Range("B2")).Protect

End Sub

需要插入的Worksheet_Change事件代码（原版本）：

Sub Worksheet_Change(ByVal Target As Range)

    Dim rngCell As Range
    Dim WFHDate As Workbook
'    Set WFHDate = Sheets("Home").Range("B2").Value

    Set rngCell = Sheets("MasterFile " & ThisWorkbook.Sheets("Home").Range("B2").Value).Cells(Target.Row, Target.Column)
    ActiveWindow.ThisWorksheets("WFH " & ThisWorkbook.Sheets("Home").Range("B2")).Select
    If rngCell <> Target Then
        Target.Interior.Color = RGB(181, 244, 0)
    Else
        If rngCell = Target Then
            Target.Interior.Color = RGB(255, 255, 255)
        End If
    End If

End Sub

解决方案 #

要实现自动给新生成的WFH + B2日期工作表添加Worksheet_Change事件，需借助VBA的代码对象模型动态写入事件代码，步骤如下：

1. 启用必要的引用 #

打开VBA编辑器（快捷键Alt+F11），点击「工具」→「引用」，勾选Microsoft Visual Basic for Applications Extensibility 5.3，点击确定。

2. 修改NewData宏代码 #

替换原NewData宏为以下代码，该代码会完成工作表生成、保护Master副本，并自动写入修正后的Worksheet_Change事件：

Option Explicit
' 需先启用Microsoft Visual Basic for Applications Extensibility 5.3引用

Sub NewData()
    Dim MasterFileWk As Worksheet
    Dim newMasterSheet As Worksheet
    Dim newWFHSheet As Worksheet
    Dim wfhSheetName As String
    Dim masterSheetName As String
    Dim wfhCodeModule As CodeModule
    Dim lineNum As Long
    Dim dateStr As String
    
    ' 获取B2的日期字符串
    dateStr = ThisWorkbook.Sheets("Home").Range("B2").Value
    masterSheetName = "MasterFile " & dateStr
    wfhSheetName = "WFH " & dateStr
    
    Set MasterFileWk = ThisWorkbook.Sheets("MasterFile")
    
    ' 生成Master副本并命名
    MasterFileWk.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set newMasterSheet = ActiveSheet
    newMasterSheet.Name = masterSheetName
    newMasterSheet.Protect ' 保护工作表
    
    ' 生成WFH副本并命名
    MasterFileWk.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set newWFHSheet = ActiveSheet
    newWFHSheet.Name = wfhSheetName
    
    ' 获取WFH工作表的代码模块
    Set wfhCodeModule = ThisWorkbook.VBProject.VBComponents(newWFHSheet.CodeName).CodeModule
    
    ' 清空原有事件代码（避免重复生成）
    On Error Resume Next
    wfhCodeModule.DeleteLines 1, wfhCodeModule.CountOfLines
    On Error GoTo 0
    
    ' 写入修正后的Worksheet_Change事件代码
    With wfhCodeModule
        lineNum = .CountOfLines + 1
        .InsertLines lineNum, "Private Sub Worksheet_Change(ByVal Target As Range)"
        lineNum = lineNum + 1
        .InsertLines lineNum, "    Dim rngCell As Range"
        lineNum = lineNum + 1
        .InsertLines lineNum, "    Dim masterSheet As Worksheet"
        lineNum = lineNum + 1
        .InsertLines lineNum, "    Dim dateStr As String"
        lineNum = lineNum + 1
        .InsertLines lineNum, ""
        lineNum = lineNum + 1
        .InsertLines lineNum, "    ' 禁用事件避免循环触发"
        lineNum = lineNum + 1
        .InsertLines lineNum, "    Application.EnableEvents = False"
        lineNum = lineNum + 1
        .InsertLines lineNum, ""
        lineNum = lineNum + 1
        .InsertLines lineNum, "    dateStr = ThisWorkbook.Sheets(""Home"").Range(""B2"").Value"
        lineNum = lineNum + 1
        .InsertLines lineNum, "    Set masterSheet = ThisWorkbook.Sheets(""MasterFile "" & dateStr)"
        lineNum = lineNum + 1
        .InsertLines lineNum, ""
        lineNum = lineNum + 1
        .InsertLines lineNum, "    ' 仅处理单个单元格修改"
        lineNum = lineNum + 1
        .InsertLines lineNum, "    If Target.Cells.Count = 1 Then"
        lineNum = lineNum + 1
        .InsertLines lineNum, "        Set rngCell = masterSheet.Cells(Target.Row, Target.Column)"
        lineNum = lineNum + 1
        .InsertLines lineNum, "        If rngCell.Value <> Target.Value Then"
        lineNum = lineNum + 1
        .InsertLines lineNum, "            Target.Interior.Color = RGB(181, 244, 0)"
        lineNum = lineNum + 1
        .InsertLines lineNum, "        Else"
        lineNum = lineNum + 1
        .InsertLines lineNum, "            Target.Interior.Color = RGB(255, 255, 255)"
        lineNum = lineNum + 1
        .InsertLines lineNum, "        End If"
        lineNum = lineNum + 1
        .InsertLines lineNum, "    End If"
        lineNum = lineNum + 1
        .InsertLines lineNum, ""
        lineNum = lineNum + 1
        .InsertLines lineNum, "    ' 恢复事件触发"
        lineNum = lineNum + 1
        .InsertLines lineNum, "    Application.EnableEvents = True"
        lineNum = lineNum + 1
        .InsertLines lineNum, "End Sub"
    End With
End Sub

3. 代码说明 #

• 新增了Application.EnableEvents = False/True，避免修改单元格时循环触发Worksheet_Change事件
• 修正了原事件代码中ActiveWindow.ThisWorksheets的语法错误，直接通过工作表对象操作
• 添加了判断Target.Cells.Count = 1，仅处理单个单元格的修改（若需支持多单元格可移除）
• 动态获取代码模块并写入事件，确保每次生成新工作表时都会添加最新的事件逻辑

内容的提问来源于stack exchange，提问作者jen