Loop row by row to send email from excel using VBA

Question

Hi,

It is a first attempt to create project in VBA. Attached my sample code. My current code checks for row 1 and send email to corresponding users. It works fine. But I want to send an email user as row by row. Say for example if row 1 email send, it should automatically trigger row 2.

Option Explicit

Sub Button1_Click()

   'Setting up the Excel variables.

   Dim perfFinTran As Workbook

   Dim olApp As Object

   Dim olMailItm As Object

   Dim iCount As Integer

   Dim Dest As Variant

   Dim SDest As String

   Dim AId As String

   Dim AName As String

   Dim FHalf As String

   Dim SHalf As String

   Dim Id As String

   Dim CC As String

   Dim strLocation As String

   'Create the Outlook application and the empty email.

   Set olApp = CreateObject("Outlook.Application")

   Set olMailItm = olApp.CreateItem(0)

   Set perfFinTran = ActiveWorkbook

   'Using the email, add multiple recipients, using a list of addresses in column A.

   With olMailItm

       Id = ""

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

           If Id = "" Then

               Id = Cells(iCount, 4).Value

           Else

               Id = Id & ", " & Cells(iCount, 4).Value

           End If

       Next iCount

       strLocation = "C:\Users..\sample.xlsx"

       .Attachments.Add (strLocation)

       .Display

    'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.

        AId = perfFinTran.Sheets("Contact").Range("B1").Value

        AName = perfFinTran.Sheets("Contact").Range("C1").Value

        FHalf = perfFinTran.Sheets("Contact").Range("E1").Value

        SHalf = perfFinTran.Sheets("Contact").Range("F1").Value

       .To = perfFinTran.Sheets("Contact").Range("B1").Value

       .CC = perfFinTran.Sheets("Contact").Range("G1").Value

       .Subject = AId & "-" & AName

       .Body = "Hello App Manager," & Chr(10) & Chr(10) & AId & "-" & AName & Chr(10) & Chr(10) & FHalf & Chr(10) & Id & "- xxxxxx" & Chr(10) & Chr(10) & SHalf

       .Display 'or use .Send

   End With

   'Clean up the Outlook application.

   Set olMailItm = Nothing

   Set olApp = Nothing

End Sub

Answer 1

Without knowing what is in your worksheet, it is virtually impossible to guess what it is that you are attempting. What for example do you mean by:

'But I want to send an email user as row by row. Say for example if row 1 email send, it should automatically trigger row 2.'?

Answer 2

See if this works for you?  It will check column B to see which row is the last with data (email address I assume), and then processes each line from 1 to that last row, skipping any lines where B is blank.

I'm not sure what the ID is all about since it seems to take data from all rows in column D, but I figure that's by design and should be in all the emails, all I did was make it loop and do the same thing the program did before, just going row by row. (New or modified lines are in bold)

Sub Button1_Click()

   'Setting up the Excel variables.

   Dim perfFinTran As Workbook

   Dim olApp As Object

   Dim olMailItm As Object

   Dim iCount As Integer

   Dim Dest As Variant

   Dim SDest As String

   Dim AId As String

   Dim AName As String

   Dim FHalf As String

   Dim SHalf As String

   Dim Id As String

   Dim CC As String

   Dim strLocation As String

   Dim lastrow As Long 'to find last row in column B with an email address

Dim i As Long

   Set perfFinTran = ActiveWorkbook

   'Create the Outlook application and the empty email.

   Set olApp = CreateObject("Outlook.Application")

   lastrow = perfFinTran.Sheets("Contact").Range("B" & Rows.Count).End(xlUp).Row

For i = 1 To lastrow

If perfFinTran.Sheets("Contact").Range("B" & i).Value = "" Then GoTo nomail

   Set olMailItm = olApp.CreateItem(0)

   'Using the email, add multiple recipients, using a list of addresses in column A.

   With olMailItm

       Id = ""

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

           If Id = "" Then

               Id = Cells(iCount, 4).Value

           Else

               Id = Id & ", " & Cells(iCount, 4).Value

           End If

       Next iCount

       strLocation = "C:\Users..\sample.xlsx"

       .Attachments.Add (strLocation)

       .Display

    'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.

        AId = perfFinTran.Sheets("Contact").Range("B" & i).Value

AName = perfFinTran.Sheets("Contact").Range("C" & i).Value

FHalf = perfFinTran.Sheets("Contact").Range("E" & i).Value

SHalf = perfFinTran.Sheets("Contact").Range("F" & i).Value

.To = perfFinTran.Sheets("Contact").Range("B" & i).Value

.CC = perfFinTran.Sheets("Contact").Range("G" & i).Value

       .Subject = AId & "-" & AName

       .Body = "Hello App Manager," & Chr(10) & Chr(10) & AId & "-" & AName & Chr(10) & Chr(10) & FHalf & Chr(10) & Id & "- xxxxxx" & Chr(10) & Chr(10) & SHalf

       .Display 'or use .Send

   End With

   'Clean up the Outlook application.

   Set olMailItm = Nothing

nomail:

Next i

   Set olApp = Nothing

End Sub