Creating a Dynamic Email Generator with Templates in Excel

Dear {{FirstName}},

Welcome to {{Company}}! We're excited to have you on board.
Your account has been set up with the following details:

Department: {{Department}}
Role: {{Role}}

Best regards,
HR Team

Hi {{FirstName}},

Thank you for your time during our discussion about {{Meeting Topic}}. As discussed, I'm following up on {{Action Item}}.
Let me know if you have any questions.

Best regards,
{{Sender Name}}

Option Explicit

Public Sub GenerateEmails()
    Dim ws As Worksheet
    Dim templateWs As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim emailBody As String
    Dim subjectLine As String
    Dim templateID As Long
    
    ' Set references to worksheets
    Set ws = ThisWorkbook.Sheets("Data")
    Set templateWs = ThisWorkbook.Sheets("Templates")
    
    ' Find last row with data
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Get template ID from user
    templateID = InputBox("Enter the Template ID number:", "Select Template")
    
    ' Get template text
    subjectLine = GetTemplate("Subject_Line", templateID)
    emailBody = GetTemplate("Email_Body", templateID)
    
    ' Convert special characters to proper line breaks
    emailBody = Replace(emailBody, "\n", vbNewLine)
    
    ' Create Outlook items
    Dim outlookApp As Object
    Dim emailItem As Object
    
    Set outlookApp = CreateObject("Outlook.Application")   
    ' Loop through each row of data
    For i = 2 To lastRow
        ' Create new email
        Set emailItem = outlookApp.CreateItem(0)
        
        With emailItem
            ' Replace placeholders with actual data
            .Subject = ReplaceFields(subjectLine, i, ws)
            .Body = ReplaceFields(emailBody, i, ws)  ' Changed from .HTMLBody to .Body
            .To = ws.Cells(i, 3).Value  ' Email address in column C
            .Display  ' Display email (change to .Send to send automatically)
        End With
    Next i
    
    Set outlookApp = Nothing
End Sub

Private Function GetTemplate(field As String, templateID As Long) As String
    Dim templateWs As Worksheet
    Dim templateRow As Range
    
    Set templateWs = ThisWorkbook.Sheets("Templates")
    
    ' Find the template row
    Set templateRow = templateWs.Columns(1).Find(What:=templateID, LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not templateRow Is Nothing Then
        Select Case field
            Case "Subject_Line"
                GetTemplate = templateWs.Cells(templateRow.Row, 3).Value
            Case "Email_Body"
                GetTemplate = templateWs.Cells(templateRow.Row, 4).Value
        End Select
    End If
End Function

Private Function ReplaceFields(text As String, rowNum As Long, ws As Worksheet) As String
    Dim result As String
    result = text  
    ' Replace all field placeholders with actual data
    result = Replace(result, "{{FirstName}}", ws.Cells(rowNum, 1).Value)
    result = Replace(result, "{{LastName}}", ws.Cells(rowNum, 2).Value)
    result = Replace(result, "{{Company}}", ws.Cells(rowNum, 4).Value)
    result = Replace(result, "{{Department}}", ws.Cells(rowNum, 5).Value)
    result = Replace(result, "{{Role}}", ws.Cells(rowNum, 6).Value)
    result = Replace(result, "{{Meeting Topic}}", ws.Cells(rowNum, 7).Value)
    result = Replace(result, "{{Action Item}}", ws.Cells(rowNum, 8).Value)
    result = Replace(result, "{{Sender Name}}", ws.Cells(rowNum, 9).Value)
    
    ReplaceFields = result
End Function