snuffnchess
Board Regular
- Joined
- May 15, 2015
- Messages
- 71
- Office Version
- 365
- Platform
- Windows
I am going to be using an excel macro to create and send out a batch of emails each week and need to make it that if for some reason we do not have an email address for a company that instead of erroring out, that it will just skip to the next line.
In addition If there is no email address, I need the file to place what is in sheet emdata, column A, and applicable row on sheet erdata column C starting at row 2, and then moving down for each item that is not present.
Here is the code that I am using to send out the emails
In addition If there is no email address, I need the file to place what is in sheet emdata, column A, and applicable row on sheet erdata column C starting at row 2, and then moving down for each item that is not present.
Here is the code that I am using to send out the emails
VBA Code:
Option Explicit
Public sfolder As String
Public sfile As String
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim emTo As String
Dim emRep As String
Dim emCC
Dim emSubject As String
Dim emBody As String
Dim emAttach As String
Dim emdata As Worksheet
Dim ob As Workbook
Dim r As Long
Dim emrng As Range
Set ob = ThisWorkbook
Set emdata = ob.Sheets("Email")
sfolder = emdata.Range("L1").Value
Set objOutlook = CreateObject("Outlook.Application")
For r = 2 To ActiveSheet.Range("A2").End(xlDown).Row
With ActiveSheet
Set emrng = emdata.Range(emdata.Cells(r, 5), emdata.Cells(r, 10))
.Range("D" & r).Value = WorksheetFunction.TextJoin(";", True, emrng)
emTo = .Range("D" & r)
emCC = .Range("C" & r).Value
emRep = .Range("C" & r).Value
emSubject = .Range("A" & r).Value & " - Report - " & Format(Now, "yyyy-mm-dd")
sfile = emdata.Range("A" & r).Value & ".xlsx"
emAttach = sfolder & "\" & sfile
emBody = "<p>Hello <b>" & .Range("A" & r).Value & " team</b>,</p>" _
& "<p>Attached is this weeks File with data from ::startdate:: to ::enddate::</p>" _
& "<p>Please let us know if you have any questions.</p>" _
& "<p>Team " & .Range("B" & r).Value & "<br>" & .Range("c" & r).Value & "</a></p>"
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = emTo
.cc = emCC
.ReplyRecipients.Add emRep
.Subject = emSubject
.HTMLBody = "<html><head></head><body>" & emBody & "</body></html>"
.Attachments.Add emAttach
.Display
'.Send
End With
Next
End Sub
