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

问题背景 #

现有可正常运行的Worksheet_Change()代码，能在指定单元格输入值时自动计算目标单元格数值，但该代码无法直接应用于通过VBA自动生成的新工作表，需要实现生成工作表与事件代码的绑定。

解决方案思路 #

动态生成工作表后，通过VBA操作其对应的代码模块，将Worksheet_Change事件代码及依赖的Max/Min函数插入到模块中，实现事件绑定。

完整整合代码 #

Sub GenerateSheetWithEvent()
    Dim ws As Worksheet
    Dim shtName As String
    Dim vbComp As VBComponent
    Dim codeModule As CodeModule
    Dim codeText As String
    
    ' 假设nachname和barcode是已定义的变量
    shtName = nachname & "_" & barcode
    Set ws = ThisWorkbook.Worksheets.Add(After:=Sheets("Analysen"))
    ws.Name = shtName
    
    ' 获取新工作表对应的代码模块
    Set vbComp = ThisWorkbook.VBProject.VBComponents(ws.CodeName)
    Set codeModule = vbComp.CodeModule
    
    ' 构建要插入的事件代码和函数
    codeText = "Private Sub Worksheet_Change(ByVal Target As Range)" & vbCrLf & _
        "    Dim Age As Long" & vbCrLf & _
        "    Dim sex_male As Boolean" & vbCrLf & _
        "    Dim SKr As Double" & vbCrLf & _
        "    Dim eGFR As Double" & vbCrLf & _
        "    Dim dob As Date" & vbCrLf & _
        "    Dim k As Double" & vbCrLf & _
        "    Dim alpha As Double" & vbCrLf & vbCrLf & _
        "    ' 读取C6单元格的出生日期" & vbCrLf & _
        "    dob = Me.Range(""C6"").Value" & vbCrLf & vbCrLf & _
        "    ' 检查日期是否有效" & vbCrLf & _
        "    If IsDate(dob) Then" & vbCrLf & _
        "        ' 计算年龄" & vbCrLf & _
        "        Age = DateDiff(""yyyy"", dob, Date)" & vbCrLf & _
        "        If Date < DateSerial(Year(Date), Month(dob), Day(dob)) Then" & vbCrLf & _
        "            Age = Age - 1" & vbCrLf & _
        "        End If" & vbCrLf & vbCrLf & _
        "    Else" & vbCrLf & _
        "        MsgBox ""Bitte gib ein valides Geburtsdatum ein""" & vbCrLf & _
        "        Exit Sub" & vbCrLf & _
        "    End If" & vbCrLf & vbCrLf & _
        "    ' 读取C4单元格的性别" & vbCrLf & _
        "    sex_male = False" & vbCrLf & _
        "    If Right(Me.Range(""C4"").Value, 1) = ""M"" Then" & vbCrLf & _
        "        sex_male = True" & vbCrLf & _
        "    End If" & vbCrLf & vbCrLf & _
        "    If Not Intersect(Target, Me.Range(""D25"")) Is Nothing Then" & vbCrLf & _
        "        If IsNumeric(Target.Value) Then" & vbCrLf & _
        "            SKr = Target.Value" & vbCrLf & vbCrLf & _
        "            ' 根据性别设置参数" & vbCrLf & _
        "            If sex_male Then" & vbCrLf & _
        "                k = 0.9" & vbCrLf & _
        "                alpha = -0.302" & vbCrLf & _
        "            Else" & vbCrLf & _
        "                k = 0.7" & vbCrLf & _
        "                alpha = -0.241" & vbCrLf & _
        "            End If" & vbCrLf & vbCrLf & _
        "            ' 用CKD-EPI公式计算eGFR" & vbCrLf & _
        "            eGFR = 141 * (Min(SKr / k, 1)) ^ alpha * (Max(SKr / k, 1)) ^ (-1.209) * (0.993 ^ Age)" & vbCrLf & vbCrLf & _
        "            ' 女性结果乘以1.018" & vbCrLf & _
        "            If Not sex_male Then" & vbCrLf & _
        "                eGFR = eGFR * 1.018" & vbCrLf & _
        "            End If" & vbCrLf & vbCrLf & _
        "            Debug.Print eGFR" & vbCrLf & _
        "            Me.Cells(Target.Row + 1, Target.Column).Value = eGFR" & vbCrLf & _
        "            Me.Cells(Target.Row + 1, Target.Column).NumberFormat = ""0.0""" & vbCrLf & _
        "        Else" & vbCrLf & _
        "            MsgBox ""Bitte gib eine Zahl im Kreatininfeld ein""" & vbCrLf & _
        "        End If" & vbCrLf & _
        "    End If" & vbCrLf & _
        "End Sub" & vbCrLf & vbCrLf & _
        "Private Function Max(num1 As Double, num2 As Double) As Double" & vbCrLf & _
        "    If num1 > num2 Then" & vbCrLf & _
        "        Max = num1" & vbCrLf & _
        "    Else" & vbCrLf & _
        "        Max = num2" & vbCrLf & _
        "    End If" & vbCrLf & _
        "End Function" & vbCrLf & vbCrLf & _
        "Private Function Min(num1 As Double, num2 As Double) As Double" & vbCrLf & _
        "    If num1 < num2 Then" & vbCrLf & _
        "        Min = num1" & vbCrLf & _
        "    Else" & vbCrLf & _
        "        Min = num2" & vbCrLf & _
        "    End If" & vbCrLf & _
        "End Function"
    
    ' 清空模块原有代码（如果需要），然后插入新代码
    codeModule.DeleteLines 1, codeModule.CountOfLines
    codeModule.AddFromString codeText
    
    Application.EnableEvents = True
End Sub

关键说明 #

• 使用Me.Range替代原代码中的Range，确保代码始终指向当前工作表的单元格，避免跨表引用错误。
• 通过VBProject.VBComponents获取新工作表的代码模块，动态插入事件代码和函数。
• 需确保Excel已启用对VBA项目对象模型的访问：
  1. 打开Excel选项 → 信任中心 → 信任中心设置 → 宏设置
  2. 勾选"信任对VBA项目对象模型的访问"

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