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

Question

我有一个功能代码，可以在另一个单元格中输入值时自动计算单元格的值 - 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

Answer 1

我认为 Tim Williams 的解决方案非常有吸引力，所以花了一些时间来建立一个工作方式。

首先，我们使用这 3 个工作表创建一个 .xlsm Excel 文档： shtTemplate 与私有模块 VBA 代码就像 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

Answer 2

抱歉回复晚了。在我说我找到了另一种方法（即插入一个按钮来完成所有计算）之后，我认为没有其他人会回应 由于这个文档将被许多没有经验的用户使用，并且最终必须在未来更新，但不是我，我认为这是最容易理解的方式（当然除了评论代码）

但是，我尝试了@Siddarth Rout 的解决方案，它工作得很好。我最初认为我不能使用它，因为它会改变所有的工作表，但是放入条件并不是那么聪明！ （呃！！）

来自@Tim Williams 的隐藏表版本对我不起作用 - 我最初确实是这样，但生成的报告在打印前被“清理”，这意味着所有行（每行都是一个参数 - A 列是名称和 col D 是测试结果）没有测试结果被删除。但是，如果公式在该字段中，它就会被认为是有价值的并保留下来。

Answer 3

所以我尝试了几个解决方案，但我再次陷入困境： 我尝试了使用隐藏表的方法，该表被复制为模板，包括计算公式。

输入所有测试结果后，我使用 sub 清除所有没有测试结果的行。

我使用此代码遍历从 9 到 200 的所有行并删除所有行，如果 A 列中有内容但 Cloumns B 到 D 中没有内容。此外，我检查 D 列中的单元格是否有错误或公式可以'被评估。

Dim i As Variant
For i = 200 To 9 Step -1
    If Cells(i, 1).Value <> "" _
    And Cells(i, 2).Value = "" _
    And Cells(i, 3).Value = "" _
    And Cells(i, 4).Value = "" _
    Or IsError(Cells(i, 4).Value) _
    And Not Cells(i, 1).Font.Bold Then
        
            Rows(i).EntireRow.Delete
    End If
Next i

'''

但是我收到运行时错误 13（不匹配），因为包含 #REF-Error 的单元格似乎与 Variant-Variabletype 不匹配。