CODEWITHSUNDEEP
vbaloopsexcel
TWDeac
TWDeac

Reputation: 1

Do While Loop to Send Multiple Emails by Row

I am looking for help with some VBA code.

I have an excel sheet with multiple columns and rows. Each row represents a different report which I must create and send via email to specific recipients. Each report is business day specific. What I am looking to do is the following. Automatically create an email for each row in a given business day. The code I pasted below works perfectly to create one email, but I would like to avoid having a macro button for each row.

I'd like the code to loop for each row in a given business day. For example, if business day 1 has 10 reports, clicking the macro would generate 10 different unique emails.

I've tried to create a do while loop, but I am running into some problems with that method and I am not entirely sure how to address the subject and body which are concatenated text cells, unique to each row.

Sub makeReports(dueDate As Date)

Dim reportsRange As Range
Dim xlCell As Range

Dim objOutlook As Outlook.Application
Dim strTo As String
Dim strCc As String
Dim strSubject As String
Dim strBody As String

'Determine reports range (from uppermost cell to last nonempty cell in column)
Set reportsRange = Range("B5", Range("B" & Cells.Rows.Count).End(xlUp))


Set objOutlook = CreateObject("Outlook.Application")

For Each xlCell In reportsRange
    If xlCell.Value = dueDate Then
        strTo = xlCell.Offset(0, 5).Value
        strCc = xlCell.Offset(0, 6).Value
        strSubject = xlCell.Offset(0, 10).Value
        strBody = xlCell.Offset(0, 11).Value

        Call createMail(objOutlook, strTo, strCc, strSubject, strBody)
    End If

Next xlCell

Set objOutlook = Nothing

End Sub


 Sub createMail(objOutlook As Outlook.Application, strTo As String, strCc As String, strSubject   As String, strBody As String)

Dim objMail As Outlook.MailItem

Set objMail = objOutlook.CreateItem(0)


With objMail
    .To = strTo
    .cc = strCc
    .Subject = strSubject
    .Body = strBody
    .display
    ' If you want to send:
    '.Send
End With

Set objMail = Nothing

End Sub


Sub test()
  Call makeReports(1)
End Sub

Private Sub CommandButton1_Click()
  Call makeReports(Date)
End Sub

Third Edit:

I have attached a screenshot of the workday function to determine the correct deliverable day

Screenshot

screenshot

Upvotes: 0

Views: 4621

Answers (1)

silentsurfer
silentsurfer

Reputation: 2428

Let's say your reports for a given business day are stored in column A, the following code should get you started: 

Sub SendReports(columnLetter As String)

    Dim reportsRange As Range
    Dim xlCell As Range

    'Determine reports range (from uppermost cell to last nonempty cell in column)
    Set reportsRange = Range(columnLetter & "1", Range(columnLetter & Cells.Rows.Count).End(xlUp))

    For Each xlCell In reportsRange
        Call CreateMail(xlCell.value)
    Next xlCell

End Sub

To test it:

Sub test()
 Call SendReports("A")
End Sub

Just change CreateMail so it accepts rngBody as a parameter.

Edit:

The following code works on my PC. Make sure you set a reference to the Outlook Object Library (in the VBA editor, select Tools>References and tick Microsoft Outlook ##.# Object Library (where ##.# is your installed version)) and delete all empty report lines in column A.

  Sub makeReports(businessDay As Integer)

    Dim reportsRange As Range
    Dim xlCell As Range

    Dim objOutlook As Outlook.Application
    Dim strTo As String
    Dim strCc As String
    Dim strSubject As String
    Dim strBody As String

    'Determine reports range (from uppermost cell to last nonempty cell in column)
    Set reportsRange = Range("A5", Range("A" & Cells.Rows.Count).End(xlUp))


    Set objOutlook = CreateObject("Outlook.Application")

    For Each xlCell In reportsRange
        If xlCell.Value = businessDay Then
            strTo = xlCell.Offset(0, 4).Value
            strCc = xlCell.Offset(0, 5).Value
            strSubject = xlCell.Offset(0, 8).Value
            strBody = xlCell.Offset(0, 7).Value

            Call createMail(objOutlook, strTo, strCc, strSubject, strBody)
        End If

    Next xlCell

    Set objOutlook = Nothing

End Sub


Sub createMail(objOutlook As Outlook.Application, strTo As String, strCc As String, strSubject As String, strBody As String)

    Dim objMail As Outlook.MailItem

    Set objMail = objOutlook.CreateItem(0)


    With objMail
        .To = strTo
        .cc = strCc
        .Subject = strSubject
        .Body = strBody
        .display
        ' If you want to send:
        '.Send
    End With

    Set objMail = Nothing

End Sub


Sub test()
 Call makeReports(1)
End Sub

Now all you need is some logic to figure out the current business day.

Edit2:

This is a modified version of the code accepting a due date as parameter and taking into account the additional column you have inserted:

  Sub makeReports(dueDate As Date)

    Dim reportsRange As Range
    Dim xlCell As Range

    Dim objOutlook As Outlook.Application
    Dim strTo As String
    Dim strCc As String
    Dim strSubject As String
    Dim strBody As String

    'Determine reports range (from uppermost cell to last nonempty cell in column)
    Set reportsRange = Range("B5", Range("B" & Cells.Rows.Count).End(xlUp))


    Set objOutlook = CreateObject("Outlook.Application")

    For Each xlCell In reportsRange
        If xlCell.Value = dueDate Then
            strTo = xlCell.Offset(0, 4).Value
            strCc = xlCell.Offset(0, 5).Value
            strSubject = xlCell.Offset(0, 8).Value
            strBody = xlCell.Offset(0, 7).Value

            Call createMail(objOutlook, strTo, strCc, strSubject, strBody)
        End If

    Next xlCell

    Set objOutlook = Nothing

End Sub

Add a command button onto your worksheet and enter the following code:

Private Sub CommandButton1_Click()
  Call makeReports(Date)
End Sub

This should open one mail for every report due today.

Upvotes: 1

Related Questions