Looping my excel VBA for sending emails

[az365]

Hi thread,

Try to set up VBA to help me automate my remittance advice sending..

I want to loop through the rows in the table. But I am so new to the VBA, I need some help.

Here is the code for my VBA.

Sub Mail()
Dim OutlookApp As Object
Dim Mess As Object, Recip
Dim Body As String
Recip = [A2].Value
Set OutlookApp = CreateObject("Outlook.Application")
Set Mess = OutlookApp.CreateItem(olMailItem)
With Mess
.Subject = [D2].Value & " " & [C2].Value & " " & "Remittance Advice"
Dim mymsg As String
mymsg = "Hi there" & vbCrLf & vbCrLf
mymsg = mymsg & "Please find the remittance advice below." & vbCrLf & vbCrLf
mymsg = mymsg & "Vendor Name:" & " " & [D2].Value & vbCrLf
mymsg = mymsg & "Invoice No.:" & " " & [E2].Value & vbCrLf
mymsg = mymsg & "Invoice Date:" & " " & [F2].Value & vbCrLf & vbCrLf
mymsg = mymsg & "Payment Date:" & " " & [C2].Value & vbCrLf
mymsg = mymsg & "Amount paid:" & " " & "$" & " " & [G2].Value & vbCrLf & vbCrLf
mymsg = mymsg & "Regards"
.Body = mymsg
.To = Recip
.Display
.Send
End With
End Sub


Is there any way to modify it to get it loop through rows?

Eg.

C2 abc@gmail.com
C3 zxy@gmail.com

loop through very end.

I also have cell reference for body contents. I need to get those contents to loop through as different row has different content.

Thanks in advance for your precious time.

AZ

 

[Logit]

.
Here is one method. Download link is : https://www.amazon.com/clouddrive/share/PjojhrK4D4jJ4K92WW9B43TRirM8PFxOu1xVKJXJFhz

Sub SendEmail()
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim cell As Range
    Dim email_ As String
    Dim cc_ As String
    Dim subject_ As String
    Dim body_ As String


     'Create Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")


     'Loop through the rows
    For Each cell In Columns("a").Cells.SpecialCells(xlCellTypeConstants)


        email_ = cell.Value
        subject_ = cell.Offset(0, 1).Value
        body_ = cell.Offset(0, 2).Value
        cc_ = cell.Offset(0, 3).Value


        'Create Mail Item and send it
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = email_
            .CC = cc_
            .Subject = subject_
            .Body = body_
            .Display
        End With
    Next
End Sub

Here is a second method. Download link is : https://www.amazon.com/clouddrive/share/zQUBf1kfRD7hwsPaeWAYVU9VGdFcZ6lOW1YkDripN0e

Option Explicit


Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")


For i = 2 To ws1.Range("B65536").End(xlUp).Row
    If ws1.Cells(i, 7) Or ws1.Cells(i, 10) = "=Today()" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
    Mail_Selection_Range_Outlook_Body
    ws2.Rows.Delete
Next i
End Sub


Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets("Sheet2").Range("A2:J2" & lEndRow).SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = Sheets("Sheet2").Range("D2").Value
    .CC = ""
    .BCC = ""
    .Subject = "Please review the latest Forecast Variable Report"


    .HTMLBody = Sheets("Sheet2").Range("B2").Value & "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    .Display
End With
On Error GoTo 0
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Hopefully one of these will fulfill the goal.

 

[az365]

Hi Logit,

Thanks a lot for sending through 2 useful links.

While I am looking at the first method.

I have 2 questions:

1. I just not sure how does the cell offset works.

2. I want to include loop in the email main text. Is it possible for you to show me how to do that?

Eg.

Main Text:

Hi there

<o></o>
Please find the remittance advice below.

<o></o>
Vendor Name: D1
Invoice No.: C1
Invoice Date: E1<o></o>
Payment Date: F1
Amount paid: $ G1 H1

<o></o>
Regards <o></o>

 

[az365]

Hi Logit,

I modified the code a bit to achieve the cell reference loop.

Thank you so much for sending through an example to inspire me.

Sub Mail()
Dim OutlookApp As Object
Dim Mess As Object, Recip
Dim Body As String
Dim cell As Range
'Loop through the rows
For Each cell In Columns("a").Cells.SpecialCells(xlCellTypeConstants)
Recip = cell.Value
Set OutlookApp = CreateObject("Outlook.Application")
Set Mess = OutlookApp.CreateItem(olMailItem)
With Mess
.Subject = cell.Offset(0, 2).Value & " " & cell.Offset(0, 3).Value & " " & "Remittance Advice"
Dim mymsg As String
mymsg = "Hi there" & vbCrLf & vbCrLf
mymsg = mymsg & "Please find the remittance advice below." & vbCrLf & vbCrLf
mymsg = mymsg & "Vendor Name:" & " " & cell.Offset(0, 3).Value & vbCrLf
mymsg = mymsg & "Invoice No.:" & " " & cell.Offset(0, 4).Value & vbCrLf
mymsg = mymsg & "Invoice Date:" & " " & cell.Offset(0, 5).Value & vbCrLf & vbCrLf
mymsg = mymsg & "Payment Date:" & " " & cell.Offset(0, 2).Value & vbCrLf
mymsg = mymsg & "Amount paid:" & " " & "$" & " " & cell.Offset(0, 6).Value & " " & cell.Offset(0, 7).Value & vbCrLf & vbCrLf
mymsg = mymsg & "Regards" & vbCrLf & vbCrLf
mymsg = mymsg & "TPG Finance"
.Body = mymsg
.To = Recip
.Display
End With
Next
End Sub

 

[Logit]

.
Glad to assist.