excel VBA Worksheet_更改由代码创建的工作表中的函数

li9yvcax  于 2023-03-04  发布在  其他
关注(0)|答案(1)|浏览(125)

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

ylamdve61#

我认为蒂姆威廉姆斯的解决方案是如此有吸引力,所以花了一段时间来建立一个工作的方式。
首先,我们使用以下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

相关问题