VBA to Outlook - Help with Looping

Hi, I am a relatively new user and am needing help in looping a macro which will send customized emails to a list of recipients using data from Excel.

I am using the code below, which works perfectly for the first row. However when Outlook opens, it generates identical emails on an endless loop. The intention is to send emails to all the recipients in Column P using the data from other columns until it reaches an empty row or cell.

Any suggestions would be greatly appreciated! Thanks.

Sub SendEmails_Click()

Dim i As Integer
Dim email, body, subject, copy, EEfirst, EElast, GDIbldgname, GDIbldgnumb, HRCbldgname, HRCbldgnumb As String
Dim OutApp As Object
Dim OutMail As Object

body = ActiveSheet.TextBoxes("TextBox 1").Text

i = 2

Do While Cells("P12").Value <> ""

    email = Range("P12").Value
    subject = Range("AB12").Value
    copy = Range("H12").Value
    EEfirst = Range("U12").Value
    EElast = Range("W12").Value
    GDIbldgname = Range("X12").Value
    GDIbldgnumb = Range("D12").Value
    HRCbldgname = Range("Y12").Value
    HRCbldgnumb = Range("C12").Value

    body = Replace(body, "U12", EEfirst)
    body = Replace(body, "W12", EElast)
    body = Replace(body, "X12", GDIbldgname)
    body = Replace(body, "D12", GDIbldgnumb)
    body = Replace(body, "Y12", HRCbldgname)
    body = Replace(body, "C12", HRCbldgnumb)

Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.createitem(0)
    With OutMail
         .To = email
         .cc = copy
         .subject = subject
         .body = body
         .display
         '.Send
    End With
    
        body = ActiveSheet.TextBoxes("TextBox 1").Text
        i = i + 1
    Loop
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    MsgBox "Email(s) Sent!"

End Sub

Take a look at a similar loop request that i helped with here: https://www.excelforum.com/excel-pro...ml#post5559778

Without a sample file hard to test your routine, but looking at this line: Do While Cells("P12").Value <> "" it will always be true, because it continues to look at that one cell.

In the link above, they were deleting the row after they ran their routine, so it will need to be tweaked a bit for you if your rows are not being deleted after each email is sent.

I cant test if the email portion works, but try this:

Sub SendEmails_Click()

Dim i As Integer
Dim email, body, subject, copy, EEfirst, EElast, GDIbldgname, GDIbldgnumb, HRCbldgname, HRCbldgnumb As String
Dim OutApp As Object
Dim OutMail As Object
Dim r As Range
Dim c As Range

body = ActiveSheet.TextBoxes("TextBox 1").Text

i = 2

    For Each r In Range("H12:H15").Rows
        For Each c In r.Cells
            If IsEmpty(c.Value) = False Then
                email = Range("P12").Value
                subject = Range("AB12").Value
                copy = c.Value
                EEfirst = Range("U12").Value
                EElast = Range("W12").Value
                GDIbldgname = Range("X12").Value
                GDIbldgnumb = Range("D12").Value
                HRCbldgname = Range("Y12").Value
                HRCbldgnumb = Range("C12").Value
            
                body = Replace(body, "U12", EEfirst)
                body = Replace(body, "W12", EElast)
                body = Replace(body, "X12", GDIbldgname)
                body = Replace(body, "D12", GDIbldgnumb)
                body = Replace(body, "Y12", HRCbldgname)
                body = Replace(body, "C12", HRCbldgnumb)
            
            Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.createitem(0)
                With OutMail
                     .To = email
                     .cc = copy
                     .subject = subject
                     .body = body
                     .display
                     '.Send
                End With
                
                    body = ActiveSheet.TextBoxes("TextBox 1").Text
                    i = i + 1
            End If
        Next c
    Next r
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    MsgBox "Email(s) Sent!"
    
End Sub

Opps thats my fault, i just noticed everything was hardcoded to row 12, let me see if i can update to work for everything..
My bad..

Try this: Sorry about that

Sub SendEmails_Click()

Dim i As Integer
Dim email, body, subject, copy, EEfirst, EElast, GDIbldgname, GDIbldgnumb, HRCbldgname, HRCbldgnumb As String
Dim OutApp As Object
Dim OutMail As Object
Dim r As Range
Dim c As Range
Dim rn As Integer

body = ActiveSheet.TextBoxes("TextBox 1").Text

i = 2
    For Each r In Range("H12:H15").Rows
        For Each c In r.Cells
            If IsEmpty(c.Value) = False Then
                rn = r.Row
                email = Range("P" & rn).Value
                subject = Range("AB" & rn).Value
                copy = c.Value
                EEfirst = Range("U" & rn).Value
                EElast = Range("W" & rn).Value
                GDIbldgname = Range("X" & rn).Value
                GDIbldgnumb = Range("D" & rn).Value
                HRCbldgname = Range("Y" & rn).Value
                HRCbldgnumb = Range("C" & rn).Value
            
                body = Replace(body, "U" & rn, EEfirst)
                body = Replace(body, "W" & rn, EElast)
                body = Replace(body, "X" & rn, GDIbldgname)
                body = Replace(body, "D" & rn, GDIbldgnumb)
                body = Replace(body, "Y" & rn, HRCbldgname)
                body = Replace(body, "C" & rn, HRCbldgnumb)
            
            Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.createitem(0)
                With OutMail
                     .To = email
                     .cc = copy
                     .subject = subject
                     .body = body
                     .display
                     '.Send
                End With
                    body = ActiveSheet.TextBoxes("TextBox 1").Text
                    i = i + 1
            End If
        Next c
    Next r
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    MsgBox "Email(s) Sent!"
    
End Sub

did you update this line to match your actual range of value?

    For Each r In Range("H12:H15").Rows

Also, prior to the above changes, your email was being built correctly with valid values?

Where is this located on your sample file?

body = ActiveSheet.TextBoxes("TextBox 1").Text

I found it in your original sample file, but just opening it the text inside the textbox seems to be hardcoded

So Close! It works in .display, but when I change to .send, it gives me a Run Time Error '287'.

I changed this section below to fix the text box issue, so it now reflects the associated cell data in the email body.

body = Replace(body, "U12", EEfirst)

Any ideas?