Custom Subject line for Outlook

Question

I'm working on automating an Excel database so by clicking a button, the macro will automatically send an email using the email, subject, and body for that specific row entry.

For example, I want to press the button and the macro automatically sends out emails to the cells filled in Red to their respective emails with the customized subject.

I found some code online that, once pressed, will send out an automatic email. However, the subject line isn't customized.

Here's the code I'm working on right now:

Sub SendReminderMail()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
Dim SUBJECT As String

Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)

With OutLookMailItem
.SUBJECT = ""
For iCounter = 1 To WorksheetFunction.CountA(Columns(4))
If SUBJECT = "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
.SUBJECT = Cells(iCounter, 6).Value
ElseIf SUBJECT <> "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
SUBJECT = SUBJECT & ";" & Cells(iCounter, 6).Value

End If
Next iCounter

MailDest = ""
For iCounter = 1 To WorksheetFunction.CountA(Columns(4))
If MailDest = "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
MailDest = Cells(iCounter, 4).Value
ElseIf MailDest <> "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
MailDest = MailDest & ";" & Cells(iCounter, 4).Value
End If

Next iCounter


.BCC = MailDest
.Body = "Reminder: Time to contact this firm"
.Send

End With

Set OutLookMailItem = Nothing
Set OutLookApp = Nothing



End Sub

Current problems I'm facing:

1. The email sends out to the correct email addresses but the subject is ALWAYS the subject in the 6th row - "Reminder to email Andrew". It doesn't change for other contacts. I need the subject to change for every email to each different contact.

2. I noticed if I have different contact names but they're listed under the same e-mail address, then the macro will only e-mail to the first entry with the same e-mail, but not the second one.

Any help is appreciated. Thanks

Answer 1

I believe you're looking for everything in between this line:

With OutLookMailItem

and this line

End With

to run ONCE for each row in your spreadsheet, am I right? For each individual row, if you have the "Send Reminder" text in Cells(iCounter,4), you want an email to be sent out to that person.

If that's the case - that's never going to happen because you iterate through this code from 1 all the way to 6

For iCounter = 1 To WorksheetFunction.CountA(Columns(4))
If SUBJECT = "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
.SUBJECT = Cells(iCounter, 6).Value
ElseIf SUBJECT <> "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
SUBJECT = SUBJECT & ";" & Cells(iCounter, 6).Value

End If

prior to ever executing this code:

.Send

This is why your .SUBJECT is always "Reminder to email Andrew." It was "Reminder to email Ner," but that was overwritten by "Reminder to email Roo", which was overwritten by "Reminder to email Andrew."

I copied your code into VBA and ran it for myself and I'm not sure how it's working for you because I can't get it to run.

If my suggestion above is not what you're looking to do, then your problem is probably lying in the fact that you are not using a . before SUBJECT in your ElseIf statement:

For iCounter = 1 To WorksheetFunction.CountA(Columns(4))
    If SUBJECT = "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
        .SUBJECT = Cells(iCounter, 6).Value
    ElseIf SUBJECT <> "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
        SUBJECT = SUBJECT & ";" & Cells(iCounter, 6).Value
     '^ period here
    End If
Next iCounter

If you're actually looking to build out the .SUBJECT property of OutlookMailItem, you need to put a period before it, as you want to reference .SUBJECT - the property of OutlookMailItem, not the variable SUBJECT (which is very confusing btw).

Some other notes:

your For loop doesn't need to start at 1, because that's your header row. It might be easier in the future to do something like this:

lastRow = Range("D" & Rows.Count).End(xlUp).Row

For iCounter = 2 to lastRow step 1
  '/ VBA will iterate through each row until it hits the end
  '/ Assuming column D has data in it to your actual "last row"
Next iCounter

Answer 2

Use F8 to step through your code. Turn on your locals window and watch what is happening with your variables at each step. Hover your cursor over the yellow line or any previous line to see what the variables / functions are at that point or when previous lines finished executing.

Pay particular attention to your subject variable.

This bit is also probably not doing what you want it to be doing:

For iCounter = 1 To WorksheetFunction.CountA(Columns(4))

If I put that into a spreadsheet with a bunch of values in columns A through J and run this:

Sub testing()
Dim X
X = WorksheetFunction.CountA(Columns(4))
End Sub

X is 0 I suspect you want the last row with a value in column D.

Sub lastrow()
Dim X
X = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
End Sub

That gives me 19. The last cell in column D with a value. You don't want to count or counta because it won't count blanks. So you might have 20 rows of data but if only 5 have a value in column D, your loop will go through 5 times, since you based it off the cells with values, not the rows.

Mainly, if you are going to be doing these regularly, play with F8 and your View/Locals window while doing this and you will start to see where things go wrong.

Then make a very simple sub like that one to play with the individual piece of code until you understand it, before you try to modify a larger complex chunk. That will help you learn to fish.

I don't have outlook so I can't test the rest of your code, but that block will give your trouble even if everything else is perfect.

Answer 3

So tempted to leave out the comment but there's still a possibility you will miss it XD

Sub SendReminderMail()

Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim lastRow As Long
Dim iCounter As Long
Dim MailDest As String
Dim subj As String

lastRow = ThisWorkbook.WorkSheets("Sheet6").Cells(Rows.Count, "D").End(xlUp).Row 'change worksheet

For iCounter = 2 To lastRow

    Set OutLookApp = CreateObject("Outlook.application")
    Set OutLookMailItem = OutLookApp.CreateItem(0)

    With OutLookMailItem
        subj = ""
        MailDest = ""

        If Cells(iCounter, 3) = "Send Reminder" Then
            subj = Cells(iCounter, 6).Value
            MailDest = Cells(iCounter, 4).Value

            .BCC = MailDest
            .SUBJECT = subj
            .Body = "Reminder: Time to contact this firm"
            .Send
        End If

    End With

Next iCounter

End Sub