I am hoping that someone can help.
I have a macro in excel that looks down a column of email address and sends an individual email to those addresses with a specified attachment.
The macro works perfectly, however I am unsure how to adapt the macro to be able to send two attachments in the same email.
Please help.
The full code is;
Sub Send()
'Working in Excel 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Email")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Subject = cell.Offset(0, 7).Value
.HTMLBody = "<html><body><p>Hello " & cell.Offset(0, -1).Value & "<p></p>" _
& cell.Offset(0, 2).Value & "</p><p>" _
& cell.Offset(0, 3).Value _
& Signature & "</body></html>"
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send
'.Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
You can run the
.Attachments.Add FileCell.Value
line twice with a different attachment path
Related
please click to view screenshot How do I copy details on each row with the table header and send the copied data to the email address on that row?
I've tried multiple ways to resolve this but can't find a solution:
Basically, I just need to copy what is on a row, send the copied values to the email address on that row.
Here's my code:
Sub AutoSendMail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("E").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "F").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "VBA TEST"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Hello, this is a vba test, please ignore. " & _
"Thank you!"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Display
End With
On Error GoTo 0
Cells(cell.Row, "G").Value = "SENT"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I have the following piece of code which sends emails in bulk.
Sub Sengrd_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
para2 = ""
para3 = ""
para232 = Range("AA2").Value
With Application
.EnableEvents = False
.ScreenUpdating = True
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Circle Profitability Report for the period ended 30-NOV-2017"
.Body = "Dear Sir/Madam," _
& vbNewLine _
& para232 & vbNewLine _
& vbNewLine & para2 & vbNewLine _
& Remark & vbNewLine & vbNewLine _
& para3 & vbNewLine & vbNewLine
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
7 different mails will be sent to different people mentioned in Column B with Attachment defined in Col C.
The Macro by default sends mails for ALL line items probably because of this line in code
**For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)**
I cannot define a variable i and change the above line to
**For Each i =1 to 5 sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)**
due to syntax error. Can anyone help me in syntax in replacing "For each cell in" to a finite range.
This is how to make the bulk-mail-sender send only to a given range (in this case B2 - B5):
For Each cell In sh.Range("B2:B5")
And do not forget - spam is bad.
I am trying to send an email to the names listed in column A but I don't have their email addresses. the email addresses are in outlook contacts. I can get it to display their emails in column B but I don't want to do that. I want to look up the email address and append it to the "To" field in the email. How it looks now is that, it only appends the email address for the last person in column A to all the emails for the other people in Column A. as seen in the pic. all the people in the A column are getting the same email address for the last person in their To field.
Option Explicit
Sub GetAddressesAndSendEmail()
Sheet10.Select
Dim o, AddressList, AddressEntry
Dim ToField As String
Dim c As range, r As range, AddressName As String
Set o = CreateObject("Outlook.Application")
Set AddressList = o.Session.AddressLists("Contacts")
Set r = Sheet10.range("A1", range("A1").End(xlDown))
For Each c In r
AddressName = c.Value
For Each AddressEntry In AddressList.AddressEntries
If AddressEntry.Name = AddressName Then
'c.Offset(0, 1).Value = AddressEntry.Address
ToField = AddressEntry.Address
'MsgBox ToField
Exit For
End If
Next AddressEntry
Next c
Dim OutApp As Object
Dim OutMail As Object
Dim cell As range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If LCase(Cells(cell.Row, "D").Value) <> "" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ToField
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
.Attachments.Add ("C:\" & Cells(cell.Row, "D").Value & ".txt")
'.Send
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Never ever loop through all items in an address book container. If the name can be resolved to a contact, all you need to do is set the MailItem.To property - when the message is sent, Outlook will resolve the name to an address. If you want to do that before sending the message, or if you really want the email address, call Application.Session.CreateRecipient - it will return an instance of the Recipient object. Call Recipient.Resolve and read Recipient.Address property. If the name cannot be resolved (if it is not found or the name is ambiguous), Recipient.Resolve will raise an exception.
Create each mail before you overwrite ToField.
For Each AddressEntry In AddressList.AddressEntries
If AddressEntry.Name = AddressName Then
'c.Offset(0, 1).Value = AddressEntry.Address
ToField = AddressEntry.Address
'MsgBox ToField
Set OutMail = o.CreateItem(0)
With OutMail
.To = ToField
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
.Attachments.Add ("C:\" & Cells(cell.Row, "D").Value & ".txt")
'.Send
.Display
End With
Set OutMail = Nothing
Exit For
End If
Next AddressEntry
Consider doing it this way.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
I have researched this topic and found great code - but not quite what I need. I have created an Excel file to setup a range for email distribution of an attachment to 3 hundred recipients - which works fine. But I have multiple attachments which need to go to the same recipient. Column A is the field where the file name is chosen - which picks up a pdf for recipient 1. Is it possible to use Column B for the second pdf file for recipient 1 and how do I loop that in?
Sub Mail_Report()
Dim OutApp As Object
Dim OutMail As Object
'Use presence of a Path to determine if a mail is sent.
Set Rng = Range(Range("J2"), Range("J" & Rows.Count).End(xlUp))
For Each cell In Rng
Rw = cell.Row
Path = cell.Value
If Path <> "" Then
'Get Date info from Path
'Dte = Right(Path, Len(Path) - InStrRev(Path, "\"))
'Get Territory to check for filename (Column A)
FilNmeStr = cell.Offset(0, -9).Value
'Email Address
ToName = cell.Offset(0, -5).Value
'Subject Line
SL = Cells(1, "K")
'Create Recipient List
For x = 1 To 4
Recp = cell.Offset(0, -x).Value
If Recp <> "" Then
Recp = cell.Offset(0, -x).Value
End If
RecpList = RecpList & ";" & Recp
Next
ccTo = RecpList
'Get Name
FirstName = cell.Offset(0, -7).Value
LastName = cell.Offset(0, -6).Value
'Loop through files in Path to see if
ClientFile = Dir(Path & "\*.*")
Do While ClientFile <> ""
If InStr(ClientFile, FilNmeStr) > 0 Then
AttachFile = Path & "\" & ClientFile
MailBody = "Hi " & FirstName & "," & vbNewLine & vbNewLine _
End If
ClientFile = Dir
Loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.SentOnBehalfOfName = """TechSupport"" <TechSupport#anycompany.com>"
.To = ToName
.cc = ccTo
.Subject = SL & " - " & cell.Offset(0, -9).Value
.Body = MailBody
.Attachments.Add (AttachFile)
.Display
'.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
RecpList = ""
End If
Next
End Sub
Try it this way.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
In excel I have the following code which sends out emails for every cell that contains an email address in column K.
This would work except for the header in the table isn't an email address, so it breaks the code. I tried to skip the header by specifying "if cell.value = CONTACT METHOD, which is the header name text, then go to Next cell"
but this causes a "Next without for" error.
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*#*" Then
finaladdress = cell.Value
Else
finaladdress = cell.Value & "#email.smsglobal.com"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = finaladdress
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
If your goal is to skip cell K1 in looping down column K then:
For Each cell In Columns("K2:K" & Rows.Count).Cells.SpecialCells(xlCellTypeConstants)
You can enclose the code within the FOR/EACH loop within a separate IF statement, as below:
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value = "CONTACT METHOD" Then
'Do Nothing, or Enter code here
Else
If cell.Value Like "*#*" Then
finaladdress = cell.Value
Else
finaladdress = cell.Value & "#email.smsglobal.com"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = finaladdress
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub