1

I have a functioning code to calculate the value of a cell automatically upon entering a value in another cell - Worksheet_Change() The problem is that the sheet I want to use it in is automatically generated and I do not seem to figure out how to combine these two.

This is the code for creating the new 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

This is the code for calculations:

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
braX
  • 11,506
  • 5
  • 20
  • 33
drevil
  • 58
  • 6
  • 1
    Hey, there are already a couple of solution to your problem on StackOverflow. Does this: https://stackoverflow.com/questions/71074592/create-excel-sheet-with-worksheet-change-code or that: https://stackoverflow.com/questions/34837006/excel-vba-add-code-to-sheet-module-programmatically solve your issue? – CHH Feb 25 '23 at 10:43
  • Hi. Thanks for your suggestion. Indeed I already tried those versions but they were not suitable for my purposes. However, I have found a simpler (but not so sexy) way. I will just add a button to calculate all appropriate cells. – drevil Feb 25 '23 at 12:24
  • 3
    There is a much easier way. Do not use `Worksheet_Change` event which lies in the `Sheet Code` module. Use the `Workbook_SheetChange` event which lies in the `ThisWorkbook` code module. Now this event will fire for all sheets. So you may want to put a condition using something like `If ws.name like nachname & "_" Then` – Siddharth Rout Feb 25 '23 at 12:53
  • 2
    Or use a hidden sheet which contains the code as a template, and make a copy of that instead of adding a new sheet. – Tim Williams Feb 25 '23 at 18:22
  • [add code programatically](https://stackoverflow.com/questions/34837006/excel-vba-add-code-to-sheet-module-programmatically) – wrbp Feb 26 '23 at 01:29
  • Does this answer your question? [Excel vba add code to sheet module programmatically](https://stackoverflow.com/questions/34837006/excel-vba-add-code-to-sheet-module-programmatically) – wrbp Feb 26 '23 at 01:31

1 Answers1

1

I think that the Tim Williams's solution is so attractive, so taken a while to set up a working way.

First we create an .xlsm Excel doc with these 3 Worksheets: shtTemplate with private module VBA code just as the OP, that will be copied data + VBA code, Sheet1 as action sheet with a form button whose click event will call the macro copyTemplateSheet(), Alalysen as position anchor sheet.

enter image description here

Second, we add a common module Module1, with this code:


'
' 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

jacouh
  • 8,473
  • 5
  • 32
  • 43