VBA Worsheet_Change 代码创建的工作表中的函数-解网

问：

我有一个有效的代码，可以在另一个单元格中输入值时自动计算一个单元格的值 - Worksheet_Change（）问题是我想使用它的工作表是自动生成的，我似乎不知道如何将这两者结合起来。

这是用于创建新 ws 的代码：

Dim ws As Worksheet
Dim shtName As String

shtName = nachname & "_" & barcode
Set ws = ThisWorkbook.Worksheets.Add(After:=Sheets("Analysen"))
ws.Name = nachname & "_" & barcode

Application.EnableEvents = True

这是计算的代码：

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Age As Long
    Dim sex_male As Boolean
    Dim SKr As Double
    Dim eGFR As Double
    Dim dob As Date
    Dim k As Double
    Dim alpha As Double

    ' Read the date of birth from cell C6
    dob = Range("C6").Value

    ' Check if the dob is a valid date
    If IsDate(dob) Then
        ' Calculate the age in years
        Age = DateDiff("yyyy", dob, Date)
        If Date < DateSerial(Year(Date), Month(dob), Day(dob)) Then
            Age = Age - 1
        End If

    Else
        ' Show an error message box
        MsgBox "Bitte gib ein valides Geburtsdatum ein"
        Exit Sub
    End If

    ' Read the sex from cell C4
    sex_male = False
    If Right(Range("C4").Value, 1) = "M" Then
        sex_male = True
    End If
    
    If Not Intersect(Target, Range("D25")) Is Nothing Then
    If IsNumeric(Target.Value) Then
    SKr = Target.Value

            'set k, alpha, and GFR values based on sex
            If sex_male Then
                k = 0.9
                alpha = -0.302
            Else
                k = 0.7
                alpha = -0.241
            End If
            
            'calculate GFR using the CKD-EPI formula
            eGFR = 141 * (Min(SKr / k, 1)) ^ alpha * (Max(SKr / k, 1)) ^ (-1.209) * (0.993 ^ Age)

            'multiply GFR by 1.018 if female
            If Not sex_male Then
                eGFR = eGFR * 1.018
            End If

        Debug.Print (eGFR)
    Cells(Target.Row + 1, Target.Column).Value = eGFR
    Cells(Target.Row + 1, Target.Column).NumberFormat = "0.0"
    Else
        MsgBox ("Bitte gib eine Zahl im Kreatininfeld ein")
    End If

End If


End Sub


Private Function Max(num1 As Double, num2 As Double) As Double
    If num1 > num2 Then
        Max = num1
    Else
        Max = num2
    End If
End Function

Private Function Min(num1 As Double, num2 As Double) As Double
    If num1 < num2 Then
        Min = num1
    Else
        Min = num2
    End If
End Function

Excel VBA 工作表函数

有一种更简单的方法。不要使用模块中的事件。使用位于代码模块中的事件。现在，此事件将针对所有工作表触发。因此，您可能希望使用类似的东西来设置条件Worksheet_ChangeSheet CodeWorkbook_SheetChangeThisWorkbookIf ws.name like nachname & "_" Then

2赞 Tim Williams 2/26/2023

或者使用包含代码的隐藏工作表作为模板，并复制该工作表，而不是添加新工作表。

0赞 wrbp 2/26/2023

以编程方式添加代码

答：

1赞 jacouh 2/27/2023 #1

我认为蒂姆·威廉姆斯（Tim Williams）的解决方案非常有吸引力，因此花了一段时间来建立一种工作方式。

首先，我们使用以下 3 个工作表创建一个 .xlsm Excel 文档：带有私有模块 VBA 代码的 shtTemplate 就像 OP 一样，它将复制数据 + VBA 代码，Sheet1 作为带有表单按钮的操作表，其单击事件将调用宏 copyTemplateSheet（），Alalysen 作为位置锚点表。

其次，我们添加一个通用模块 Module1，代码如下：


'
' copy the template Sheet, and name it as appropriate:
'
Sub copyTemplateSheet()
    Dim ws As Worksheet
    Dim shtName As String
    Dim barcode As String, nachname As String
    
    nachname = "Scholz"
    barcode = "1234567890123"

    shtName = nachname & "_" & barcode
    '
    'Set ws = ThisWorkbook.Worksheets.Add(After:=Sheets("Analysen"))
    '
    ThisWorkbook.Worksheets("shtTemplate").Copy After:=Sheets("Analysen")
    Set ws = ActiveSheet
    ws.Name = getNextSheetName(shtName)
    Set ws = Nothing
    
    Application.EnableEvents = True
    
End Sub

'
' get next available Sheet name to avoid duplication:
'
Function getNextSheetName(ByVal strSheetName As String)
    Dim i As Long
    Dim strNewSheetName
    
    Dim objSheet As Worksheet

    On Error Resume Next
    Err.Clear
    '
    i = 1
    strNewSheetName = strSheetName
    '
    Do While (True)
    
      Set objSheet = ThisWorkbook.Sheets(strNewSheetName)
      '
      ' if the Sheet does not exist:
      '
      If (Err) Then
        GoTo ExitStatus
      '
      ' otherwise the Sheet exists:
      '
      Else
        i = i + 1
        strNewSheetName = strSheetName & "_" & i
      End If
    Loop
    
ExitStatus:
    On Error GoTo 0
    Err.Clear
    Set objSheet = Nothing
    getNextSheetName = strNewSheetName
End Function

上一个：如何在同一行中添加多个VBA WorksheetFunctions？

下一个：VBA Excel 递增的工作表名称 Add After 语句使用存储的变量工作表名称

VBA Worsheet_Change 代码创建的工作表中的函数

VBA Worsheet_Change Function in a worksheet that is created by code

评论