Untitled

Sub SendLettersToMultipleRecipients()

    Dim wordApp As Object
    Dim wordDoc As Object
    Dim ws As Worksheet
    Dim recipientName As String
    Dim recipientAddress As String
    Dim dateStr As String
    Dim apeAmount As String
    Dim recipientEmail As String
    Dim ccEmail As String
    Dim bccEmail As String
    Dim lastRow As Long
    Dim i As Long
    
    ' Open Excel workbook and set worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your worksheet name
    
    ' Find the last row with data in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Initialize Word application
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = True ' Set to True for debugging purposes, change to False to run in background
    
    ' Loop through each row with data
    For i = 1 To lastRow
        ' Read dynamic data from Excel
        recipientName = ws.Cells(i, 1).Value ' Column A
        recipientAddress = ws.Cells(i, 2).Value ' Column B
        dateStr = ws.Cells(i, 3).Value ' Column C
        apeAmount = ws.Cells(i, 4).Value ' Column D
        recipientEmail = ws.Cells(i, 5).Value ' Column E
        ccEmail = ws.Cells(i, 6).Value ' Column F
        bccEmail = ws.Cells(i, 7).Value ' Column G
        
        ' Open the letter template
        Set wordDoc = wordApp.Documents.Open("C:\Path\To\Your\Template.docx") ' Change path to your template file
        
        ' Replace placeholders in the letter template with dynamic data
        With wordDoc.Content.Find
            .Text = "<Date>"
            .Replacement.Text = dateStr
            .Execute Replace:=wdReplaceAll
            .Text = "<RecipientName>"
            .Replacement.Text = recipientName
            .Execute Replace:=wdReplaceAll
            .Text = "<Address>"
            .Replacement.Text = recipientAddress
            .Execute Replace:=wdReplaceAll
            .Text = "<APEAmount>"
            .Replacement.Text = apeAmount
            .Execute Replace:=wdReplaceAll
        End With
        
        ' Save the letter as PDF
        wordDoc.SaveAs2 "C:\Path\To\Save\" & recipientName & "_Letter.pdf", FileFormat:=17 ' Save PDF with recipient's name
        
        ' Close Word document
        wordDoc.Close
        
        ' Send email with the PDF attachment
        SendEmail recipientEmail, ccEmail, bccEmail, "Your Subject", "Your Body", "C:\Path\To\Save\" & recipientName & "_Letter.pdf" ' Call SendEmail function with appropriate parameters
    Next i
    
    ' Quit Word application
    wordApp.Quit
    
    ' Notify user that letters have been generated and sent
    MsgBox "Letters have been generated and sent to the specified recipients.", vbInformation

End Sub

Sub SendEmail(recipient As String, ccRecipient As String, bccRecipient As String, subject As String, body As String, attachmentPath As String)
    Dim outlookApp As Object
    Dim outlookMail As Object
    
    ' Initialize Outlook application
    Set outlookApp = CreateObject("Outlook.Application")
    
    ' Create a new email
    Set outlookMail = outlookApp.CreateItem(0)
    
    ' Fill email details
    With outlookMail
        .To = recipient
        .CC = ccRecipient
        .BCC = bccRecipient
        .Subject = subject
        .Body = body
        .Attachments.Add attachmentPath
        .Send
    End With
    
    ' Release Outlook objects
    Set outlookMail = Nothing
    Set outlookApp = Nothing
End Sub