In this email sender how do I replace the text "employee_name" and "voucher_no" with the value in a cell.
Trying to send personalized email with an individual voucher for each email address.
Sub bulk_emails()
Dim ol As Outlook.Application
Dim olm As Outlook.MailItem
Dim inspect As Outlook.Inspector
Dim wd As Word.Document
Set ol = New Outlook.Application
For r = 2 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Sheet2.Range("C7:R26").Copy
Set olm = ol.CreateItem(olMailItem)
With olm
'Display
.To = Sheet1.Cells(r, 3).Value
.Subject = Sheet2.Range("C6").Value
.Body = Sheet1.Cells(r, 2).Value
.BodyFormat = olFormatHTML
.Display
Set inspect = olm.GetInspector
Set wd = inspect.WordEditor
wd.Content.Paste
.HTMLBody = Replace(.HTMLBody, "employee_name", Sheet1, Cells(r, 1), Value)
.HTMLBody = Replace(.HTMLBody, "voucher.no", Sheet1, Cells(r, 2), Value)
End With
Next
Set olm = Nothing
Set ol = Nothing
Set wd = Nothing
End Sub
Related
I have developed a template with which I can automate invoice reminders by outputting emails. Currently the code loops through the list outputting an email for each individual row (= each individual invoice). I would like to update the code so that it skips outfiltered rows in the excel doc to make it more efficient and easier in use.
My code is as follows:
Sub Send_email_fromtemplate()
Dim edress As String
Dim cc1, cc2, cc3 As String
Dim group As String
Dim number As String
Dim outlookapp As Object
Dim outlookmailitem As Object
Dim r As Long
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
r = 3
Do While Sheet1.Cells(r, 1) <> ""
Set outlookapp = CreateObject("Outlook.Application")
'call your template
Set outlookmailitem = outlookapp.CreateItemFromTemplate([location])
outlookmailitem.Display
edress = Sheet1.Cells(r, 7)
cc1 = Sheet1.Cells(r, 8)
cc2 = Sheet1.Cells(r, 9)
cc3 = Sheet1.Cells(r, 10)
group = Sheet1.Cells(r, 4)
number = Sheet1.Cells(r, 3).Value
With outlookmailitem
.To = edress
.cc = cc1 & ";" & cc2 & ";" & cc3
.bcc = ""
.Subject = "First invoice reminder " & group
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:="{{Number}}")
oRng.Text = number
Exit Do
Loop
End With
Set xInspect = outlookmailitem.GetInspector
.Display
'.send
End With
'clear your email address
edress = ""
r = r + 1
Loop
'clear your fields
Set outlookapp = Nothing
Set outlookmailitem = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub
I've tried to solve the problem using a Range function and ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible), but as the template will be filled with a variable number of rows (each time I send reminders) this is causing troubles, as the range differs each time.
Please, try the next updated code. As I said in my above comment, it is able to calculate the last row on A:A, then create a range from visible rows of the filtered area and iterate between its rows:
Sub Send_email_fromtemplate()
Dim edress As String, cc1 As String, cc2 As String, cc3 As String
Dim group As String, number As String
Dim outlookapp As Object, outlookmailitem As Object, olInsp As Object
Dim wdDoc As Object, xInspect As Object
Dim oRng As Object, lastR As Long, rngVis As Range, r As Range
lastR = Sheet1.Range("A" & Sheet1.rows.count).End(xlUp).row 'last row on A:A
On Error Resume Next 'this is necessary in case of no any filtered visible cell
Set rngVis = Sheet1.Range("A3:J" & lastR).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngVis Is Nothing Then MsgBox "No visible filtered values in the necessary range...": Exit Sub
Set outlookapp = CreateObject("Outlook.Application") 'you should set it only ones, outside of the iteration...
For Each r In rngVis.rows 'iterate between the discontinuous (visible cells) rows
'call your template
Set outlookmailitem = outlookapp.CreateItemFromTemplate([Location])
outlookmailitem.Display
edress = r.cells(1, 7) 'extract the necessary values from the iterated row
cc1 = r.cells(1, 8)
cc2 = r.cells(1, 9)
cc3 = r.cells(1, 10)
group = r.cells(1, 4)
number = r.cells(1, 3).Value
With outlookmailitem
.To = edress
.cc = cc1 & ";" & cc2 & ";" & cc3
.BCC = ""
.Subject = "First invoice reminder " & group
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:="{{Number}}")
oRng.Text = number
Exit Do
Loop
End With
Set xInspect = outlookmailitem.GetInspector
.Display
'.send
End With
'clear your email address
edress = ""
Next r
'clear memory of used objects:
Set outlookapp = Nothing: Set outlookmailitem = Nothing
Set wdDoc = Nothing: Set oRng = Nothing
End Sub
Please, send some feedback after testing it.
I have this code which uses an Excel sheet to create Outlook emails with attachments. It creates the emails correctly and Display works fine, but I cannot get SendUsingAccount to send the emails (manual sending of each email after Display works fine).
Could someone please point out the error?
Many thanks!
Sub Send_Files()
Dim Sht As Worksheet
Dim olApp As Object, olMail As Object, olRecip As Object, olAtmt As Object
Dim iRow As Long
Dim Recip As String, Subject As String, Atmt As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim OutAccount As Outlook.Account
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
Set OutAccount = OutApp.Session.Accounts.Item(2)
Application.EnableEvents = False
Application.ScreenUpdating = False
iRow = 2
Set olApp = CreateObject("Outlook.Application")
Set Sht = ThisWorkbook.Worksheets("Mailinglist_1")
Do Until IsEmpty(Sht.Cells(iRow, 1))
Recip = Sht.Cells(iRow, 2).Value
Subject = Sht.Cells(iRow, 4).Value
Atmt = Sht.Cells(iRow, 3).Value
Set olMail = olApp.CreateItem(0)
With olMail
Set olRecip = .Recipients.Add(Recip)
Set olMail.SendUsingAccount = OutAccount
.Subject = "Test 2021"
.Body = "Dear " & Sht.Cells(iRow, 1).Value & "," & vbNewLine & vbNewLine & _
"Text" & vbNewLine & _
"Text" & vbNewLine & _
"The Team"
olRecip.Resolve
Set olAtmt = .Attachments.Add(Atmt)
Set .SendUsingAccount = OutAccount
.Send
End With
iRow = iRow + 1
Loop
Set olApp = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The VBA code below sends email with a specific range in body.
Despite selecting only visible cells, I receive all cells.
It seems SpecialCells(xlCellTypeVisible).Select does not work.
Sub VBA_AUTO_MAIL()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Arkusz1")
Dim lr As Integer
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
sh.Range("A1:H" & lr).SpecialCells(xlCellTypeVisible).Select
ThisWorkbook.EnvelopeVisible = True
With Selection.Parent.MailEnvelope.Item
.to = sh.Range("L6").Value
.cc = sh.Range("L8").Value
.Subject = sh.Range("L9").Value
.attachments.Add "C:\Users\test\Desktop\TEST VBA\TEST_VBA.txt"
.send
End With
End Sub
I expect only visible columns in email body but I receive all columns.
Try the following
Option Explicit
Sub VBA_AUTO_MAIL()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Arkusz1")
Dim lr As Long
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
Dim rng As Range
Set rng = sh.Range("A1:H" & lr).SpecialCells(xlCellTypeVisible)
rng.Copy
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
Dim Email As Object
Set Email = olApp.CreateItem(0)
Dim wdDoc As Word.Document
Set wdDoc = Email.GetInspector.WordEditor
With Email
.To = sh.Range("L6").Value
.CC = sh.Range("L8").Value
.BCC = ""
.Subject = sh.Range("L9").Value
'.Attachments.Add "C:\Users\test\Desktop\TEST VBA\TEST_VBA.txt"
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
.Send
End With
End Sub
Make sure to Reference Microsoft Word xx.x Object Library
https://stackoverflow.com/a/42662697/4539709
This is the first time I am trying from Excel to send email using VBA code.
Here is my structure of my Excel. Sometimes the email list will have 1 - 20 or only 1 also
A (col) B C D E F G
Sl.No First Name To Email CC Email Subj File to Send Message
Code:
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("C2")
Set rngSubject = .Range("E2")
Set rngBody = .Range("G2")
Set rngAttach = .Range("F2")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
Here is my code this was working perfectly fine but for single emails to send, but not for multiple email.
I am struggling here to find how to send for multiple email with attachment using the tested code.
Maybe Try this:
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim i As Integer
Set objOutlook = CreateObject("Outlook.Application")
For i = 2 To 21 ' Loop from 2 to 21
With ActiveSheet
Set rngTo = .Range("C" & i)
Set rngSubject = .Range("E" & i)
Set rngBody = .Range("G" & i)
Set rngAttach = .Range("F" & i)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.HTMLBody = "<B><U>" & rngBody.Value & ":</B></U>"
.Attachments.Add rngAttach.Value
.Display
End With
Set objMail = Nothing
Next
Set objOutlook = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
You can loop through the Range to generate 20 emails.
Update
Added .HTMLBody instead of .Body to make text Bold And Underlined
You can use more HTML commands to make certain portions of the Text Bold and More.
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
You need a loop for that. The below code will start with the second row and continue until it finds an empty row.
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Dim r As Long: For r = 2 To ActiveSheet.Range("C2").End(xlDown).Row
With ActiveSheet
Set rngTo = .Range("C" & r)
Set rngSubject = .Range("E" & r)
Set rngBody = .Range("G" & r)
Set rngAttach = .Range("F" & r)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.to = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
.Send ' If you want to send it without clicking
End With
Next
End Sub
Also note: These Set x = Nothing lines are superfluous, delete them because they just make the code less readable for humans. Regarding this issue you can also refer to this SO question: Is there a need to set Objects to Nothing inside VBA Functions
Update
Sorry this line has to be inside the loop, I updated the code:
Set objMail = objOutlook.CreateItem(0)
I have a folder with 50 files and I have a list of 50 email addresses. Each file goes to a different email address. Is there a way to write a macro that performs this task?
The problem with the set of code below is two-fold:
1) I have 3 COLUMNS of data in an Excel file: One for subject, one for email address to send to, and the third for the FILE PATH of where the attachment to be attached is stored.
The code below does not allow for a pre-determined set of subject arguments. It also uses ROWS?? for the filepath field instead of a column like it does for send to? So confusing.
Sub Send_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
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
Here is quick example, assuming col A = Email, Col B = Subject & Col C = Path
Option Explicit
Public Sub Example()
Dim olApp As Object
Dim olMail As Object
Dim olRecip As Object
Dim olAtmt As Object
Dim iRow As Long
Dim Recip As String
Dim Subject As String
Dim Atmt As String
iRow = 2
Set olApp = CreateObject("Outlook.Application")
Dim Sht As Worksheet
Set Sht = ThisWorkbook.Worksheets("Sheet1")
Do Until IsEmpty(Sht.Cells(iRow, 1))
Recip = Sht.Cells(iRow, 1).Value
Subject = Sht.Cells(iRow, 2).Value
Atmt = Sht.Cells(iRow, 3).Value ' Attachment Path
Set olMail = olApp.CreateItem(0)
With olMail
Set olRecip = .Recipients.Add(Recip)
.Subject = Subject
.Body = "Hi "
.Display
Set olAtmt = .Attachments.Add(Atmt)
olRecip.Resolve
End With
iRow = iRow + 1
Loop
Set olApp = Nothing
End Sub