Using Loops do create emails from Excel

[big45feet]

Hi all,
I am a newbie to VBA and am having diffculty getting my code to work for more than one email addresss.
What I am trying ACHIEVE is send emails to those with the reservation date (column K) highligthed in red which will have an associated drawing number and date in the body of the email. I have managed to create this for 1st recipient but i'm having trouble looping through the contacts and sending everyone else with there date highligthed in red an individual email with there specialsed drawing number and reservation date.
Here is what i have so far, i have also included a screenshot of the spreadsheet

Sub SendReminderMail()
Dim OutLookApp As Outlook.Application
Dim OutLookMailItem As Outlook.MailItem
Dim C As Integer
Dim C2 As Integer
Dim MailDest As String
Dim DrawNum As String

''Allow access to OutLook
Set OutLookApp = CreateObject("OutLook.Application")
Set OutLookMailItem = OutLookApp.CreateItem(0)

On Error GoTo cleanup

DrawNum = ""
For C2 = 1 To WorksheetFunction.CountA(Columns(11)) 'counter increments as it passes through the rows of Column 11 or K = reservation expiry
If DrawNum = "" And Cells(C2, 11).Interior.ColorIndex = 3 Then 'the drawing numbers with there expiry dates highligthed in red will be collected
DrawNum = Cells(C2, 11).Offset(0, -9).Value
ElseIf DrawNum <> "" And Cells(C2, 11).Interior.ColorIndex = 3 Then
DrawNum = "Your reservation for Electrical Drawing Number: " & Cells(C2, 11).Offset(0, -9).Value & " expires on the " & Cells(C2, 11).Value & "."
End If

MailDest = ""
For C = 1 To WorksheetFunction.CountA(Columns(11)) 'counter increments as it passes through the rows of Column 11 or K = reservation expiry
If MailDest = "" And Cells(C, 11).Interior.ColorIndex = 3 Then 'the emails with there expiry date highligthed in red will be collected
MailDest = Cells(C, 11).Offset(0, 1).Value 'And DrawNum = Cells(C, 11).Offset(0, -9).Value
ElseIf MailDest <> "" And Cells(C, 11).Interior.ColorIndex = 3 Then
MailDest = Cells(C, 11).Offset(0, 1).Value
End If

Next C
Next C2


With OutLookMailItem
.To = MailDest
.Subject = "Electrical Drawing Reminder"
.Body = DrawNum
.Display
End With

On Error Resume Next
Set OutLookApp = Nothing
Set OutLookMailItem = Nothing

On Error GoTo 0

''once email is sent OutLookMailItem and OutLookApp are intialised
''error blocker, blocks irrelevant or neigible error messages from appearing
cleanup:
Set OutLookApp = Nothing
Application.ScreenUpdating = True
End Sub

[Bob Phillips]

Sub SendReminderMail()
Dim OutLookApp As Outlook.Application
Dim OutLookMailItem As Outlook.MailItem
Dim C As Integer
Dim C2 As Integer
Dim MailDest As String
Dim DrawNum As String

    ''Allow access to OutLook
    Set OutLookApp = CreateObject("OutLook.Application")
    Set OutLookMailItem = OutLookApp.CreateItem(0)
    
    On Error GoTo cleanup
    
    DrawNum = "": MailDest = ""
    For C2 = 1 To WorksheetFunction.CountA(Columns(11)) 'counter increments as it passes through the rows of Column 11 or K = reservation expiry
        
        If Cells(C2, 11).Interior.ColorIndex = 3 Then 'the drawing numbers with there expiry dates highligthed in red will be collected
        
            If DrawNum = "" Then
            
                DrawNum = Cells(C2, 11).Offset(0, -9).Value
            ElseIf DrawNum <> "" And Cells(C2, 11).Interior.ColorIndex = 3 Then
            
                DrawNum = "Your reservation for Electrical Drawing Number: " & Cells(C2, 11).Offset(0, -9).Value & " expires on the " & Cells(C2, 11).Value & "."
            End If
        
            MailDest = Cells(C2, 11).Offset(0, 1).Value
        
            With OutLookMailItem
            
                .To = MailDest
                .Subject = "Electrical Drawing Reminder"
                .Body = DrawNum
                .Display
            End With
        End If
    Next C2
    
    On Error Resume Next
    Set OutLookApp = Nothing
    Set OutLookMailItem = Nothing
    On Error GoTo 0
    
    ''once email is sent OutLookMailItem and OutLookApp are intialised
    ''error blocker, blocks irrelevant or neigible error messages from appearing
cleanup:
    Set OutLookApp = Nothing
    Set OutLookMailItem = Nothing
    Application.ScreenUpdating = True
End Sub

[big45feet]

Thank you Xld. I have implemented your changes but when i run the code and change .display to .send only the 1st email address is emailed.

[Bob Phillips]

When you have .Display, does it show all of the workbooks to be emailed, or is that just one as well?

Post the workbook and let's see it for ourselves.

[big45feet]

[big45feet]

At the moment the code runs for one worksheet for .display or .send, I have placed buttons on each worksheet Linking to the module containing this code.
I have uploaded the excel file

[big45feet]

the code is located in module 22, i've made a few changes but it still gives me the same results as the code you posted xld. thanks for looking into this for me

[Bob Phillips]

I can only see one worksheet with one red cell, so you would expect just one email. Even then, the red is in column 11 and you are now testing column 10.

I change the code to column 11, added another red, and got both output.

[big45feet]

sorry I had 2 copies of the code one in module 1 and the other in module 22 coz some of the worksheets have the reservation expiry column in column 10

[big45feet]

I don't no y it isn't working for me but I still only get the 1st email reminder being sent and the rest are ignored. Did u change any settings xld

[gmayor]

Having looked at your worksheet and the code, the reason you only get one message (for the last red item) is that you create the message outside the loop. You need to create the messages inside the loop.

I didn't understand what you were trying to achieve with the conditional DrawNum variable, so it would appear you can simplify that.

I didn't like the use of C2 as a variable name so I have changed it to something more meaningful.

The screen shot shows that the first row with data is 5, so start the loop there.

I prefer to address the cells directly rather than use offset (as it is easier to follow), but offset would work well provided you have the correct column references.

I have changed to late binding to Outlook (you won't need a reference to Outlook in the project), and if Outlook is already open it is faster to use the open instance of Outlook than to create one.

Option Explicit

Sub SendReminderMail()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iRow As Long
Dim MailDest As String
Dim DrawNum As String
Dim LastRow As Long
Dim xlSheet As Worksheet
Dim bStarted As Boolean

    Set xlSheet = ActiveSheet
    ''Allow access to OutLook
    On Error Resume Next
    'Get Outlook if it's running
    Set OutLookApp = GetObject(, "Outlook.Application")

    'Outlook wasn't running, start it from code
    If Err <> 0 Then
        Set OutLookApp = CreateObject("Outlook.Application")
        bStarted = True
    End If
    On Error GoTo Cleanup

    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For iRow = 5 To LastRow
            If .Cells(iRow, 11).Interior.ColorIndex = 3 Then
                DrawNum = "Your reservation for Electrical Drawing Number: " & _
                          .Cells(iRow, 2).Value & " expires on the " & _
                          .Cells(iRow, 11).Value & "."

                MailDest = .Cells(iRow, 12).Value
                Set OutLookMailItem = OutLookApp.CreateItem(0)
                With OutLookMailItem
                    .BodyFormat = 1
                    .To = MailDest
                    .Subject = "Electrical Drawing Reminder"
                    .body = DrawNum
                    .Display        'Change to .Send after testing
                End With
            End If
            DoEvents
        Next iRow
    End With

Cleanup:
    If bStarted Then OutLookApp.Quit
    Set OutLookApp = Nothing
    Set OutLookMailItem = Nothing
    Application.ScreenUpdating = True
End Sub

[big45feet]

thank you so much gmayor the code works perfectly