I am attempting to adapt the code to use column "J" as the reference column but with little success. I am not sure what I am missing to have the code use column "J" instead of column "A". Everything works as expected, the code just still references column "A" to get the email address to send to.
Sub EmailItems()
'Creates emails, attaches items, and choice to send automatically or have them pop up for your
review. Delete the "'" in front of .Send in order to send automatically
Dim MailDest As String
Dim subj As String
Dim att As Variant
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim lastRow As Long
lastRow = ThisWorkbook.Worksheets("Email").Cells(Rows.Count, "J").End(xlUp).Row
For i = 2 To lastRow
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
Set Attach = OutLookMailItem.Attachments
With OutLookMailItem
.SentOnBehalfOfName = [O6]
.To = Cells(i, 1).Value
.Subject = [O5]
.Body = [O7] & vbNewLine & vbNewLine & [O9] & vbNewLine & vbNewLine & [O11] & vbNewLine &
vbNewLine & [O13] & vbNewLine & [O14] & vbNewLine & [O15] & vbNewLine & [O16]
On Error Resume Next
For Each att In Split(Cells(i, 2).Value, ",")
Attach.Add [O2] & att & [O3]
Next
.Display
On Error GoTo 0
'.Send
End With
Next
End Sub
Use the code below:
Sub EmailItems()
'Creates emails, attaches items, and choice to send automatically or have them pop up for your
review. Delete the "'" in front of .Send in order to send automatically
Dim MailDest As String
Dim subj As String
Dim att As Variant
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim lastRow As Long
lastRow = ThisWorkbook.Worksheets("Email").Cells(Rows.Count, "J").End(xlUp).Row
For i = 2 To lastRow
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
Set Attach = OutLookMailItem.Attachments
With OutLookMailItem
.SentOnBehalfOfName = [O6]
.To = Cells(i, 10).Value
.Subject = [O5]
.Body = [O7] & vbNewLine & vbNewLine & [O9] & vbNewLine & vbNewLine & [O11] & vbNewLine &
vbNewLine & [O13] & vbNewLine & [O14] & vbNewLine & [O15] & vbNewLine & [O16]
On Error Resume Next
For Each att In Split(Cells(i, 2).Value, ",")
Attach.Add [O2] & att & [O3]
Next
.Display
On Error GoTo 0
'.Send
End With
Next
End Sub
Related
My goal: An Excel spreadsheet with VBA code, where
- User ID in Column A is used for the sending address.
- user's first name in Column B is used in the greeting line of the email body.
What I have: I created multiple emails with an email body for each User ID in Column A.
What I cannot figure out: How to use the name from Column B in the email body.
For every email:
Here is the code thus far, asterisks have been used to replace email text.
Sub SendEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
Dim strbody As String
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
strbody = "Hello " & vbNewLine & _
"***********************" & vbNewLine & vbNewLine & _
"***********************" & vbNewLine & _
"***********************" & vbNewLine & vbNewLine & _
"***********************" & vbNewLine & _
"***********************" & vbNewLine
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = Range("C2").Value
.To = Range("A" & i).Value
.Body = strbody
.SentOnBehalfOfName = "*****"
'.Send
.display 'disable display and enable send to send automatically
End With
Next i
'MsgBox "E-mail successfully sent", 64
'Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
Just add the value from cell(2,i) to .body in the loop like below
`Sub SendEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
Dim strbody As String, Strbody1 as String
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
strbody = "Hello "
strbody1 = vbNewLine & _
"***********************" & vbNewLine & vbNewLine & _
"***********************" & vbNewLine & _
"***********************" & vbNewLine & vbNewLine & _
"***********************" & vbNewLine & _
"***********************" & vbNewLine
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = Range("C2").Value
.To = Range("A" & i).Value
.Body = strbody & Range("B" & i).Value & strbody2
.SentOnBehalfOfName = "*****"
'.Send
.display 'disable display and enable send to send automatically
End With
Next i
'MsgBox "E-mail successfully sent", 64
'Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub`
Will give my comment as an answer:
First, do the Excel activities at once, storing what's needed in variables so you're not changing focus back and fourth between Excel/Outlook:
Public toString as String
Private Sub excelActivities()
with thisworkbook.sheets("NAME")
dim lr as long
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
dim i as long
for i = 2 to lr
toString = toString & ";" & .Cells(i,1).Value
next i
end with
End Sub
Then you can use your Excel values, stored as variables, when performing your Outlook activities... could be two separate subroutines called in series:
Sub generateEmail()
excelActivities
outlookActivities
End Sub
Your outlookActivities would include creating the email, adding the .To = toString, etc.
I am not able to filter the selected mail item by Subject.
The issue is that
If TypeOf Items(1) Is Outlook.MailItem And Items(1).Restrict(sFilter) Then
is triggering the error
Run time error 438: Object doesn't support this property or method.
Steps:
Loop through cells for different subject names
Search the inbox and Sentitem folders for the latest email for selected "Subject" as sometimes people do not respond to your email. So latest email is in the sent items and not in your inbox
select the latest email and reply to all
For the body of the email, I am running another function to get the required info.
The code:
Sub AccessInbox6()
'Early binding
Dim Olook As Outlook.Application ' to access all the libraries of outlook
Set Olook = New Outlook.Application
Dim sFilter As String
Dim sSubject As String
' Restrict items and running the loop
Sheet1.Range("A2").Select
Do Until ActiveCell.Value = "" 'Using this to loop over multiple cells containing subjects
sSubject = ActiveCell.Value
sFilter = "[Subject] = '" & sSubject & "'"
Dim Items As Outlook.Items
Set Items = Olook.GetNamespace("MAPI") _
.GetDefaultFolder(olFolderInbox).Items 'Checking the inbox
Dim Items2 As Outlook.Items
Set Items2 = Olook.GetNamespace("MAPI") _
.GetDefaultFolder(olFolderSentMail).Items 'Checking the sent items
Items.Sort "ReceivedTime", True 'to put them in order by date
Items2.Sort "ReceivedTime", True 'to put them in order by date or I should use "SentOn"
'Items2.Sort "SentOn", True
If Items.Item(1).ReceivedTime > Items2.Item(1).ReceivedTime Then 'Here I am checking which email is latest by date either in inbox or SentItems
If TypeOf Items(1) Is Outlook.MailItem And Items(1).Restrict(sFilter) Then 'Getting error here - Here I am checking if the "Subject of the email matches with what I have in the excel sheet
Debug.Print Items(1).Subject ' Print on Immediate Window
With Items(1).ReplyAll
.Display
.Body = "Dear Someone" & vbNewLine & vbNewLine & GetPSMUpdate2 & vbNewLine & vbNewLine & "Sincerely," & vbNewLine & "XX-"
'.Attachments.Add Environ("UserProfile") & "\Desktop\Tracking Sheet.xlsx"
.To = "XXX#gmail.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"
End If
Else
If TypeOf Items2(1) Is Outlook.MailItem And Items2(1).Restrict(sFilter) Then
Debug.Print Items(1).Subject ' Print on Immediate Window
With Items(1).ReplyAll
.Display
.Body = "Dear Someone" & vbNewLine & vbNewLine & GetPSMUpdate2 & vbNewLine & vbNewLine & "Sincerely," & vbNewLine & "XX-"
'.Attachments.Add Environ("UserProfile") & "\Desktop\Tracking Sheet.xlsx"
.To = "XXX#gmail.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Function GetPSMUpdate2() As String
Dim PSMColumn As Range, PSMRow As Range, r As Range, C As Range
Dim Str As String
Sheet2.Activate
Set PSMColumn = Range("A2", Range("A1").End(xlDown))
For Each r In PSMColumn
Set PSMRow = Range(r, r.End(xlToRight))
For Each C In PSMRow
Str = Str & C.Value
If C.Column < r.End(xlToRight).Column Then
Str = Str & vbTab
End If
Next C
If r.Row < Range("A1").End(xlDown).Row Then
Str = Str & vbNewLine
End If
Next r
GetPSMUpdate2 = Str
End Function
Use of Item in the variable names causes some confusion as well the filter could be separated.
Option Explicit
Sub AccessInbox6Fix()
'Early binding
Dim Olook As outlook.Application
Dim ItemsRaw As outlook.Items
Dim Items2Raw As outlook.Items
Dim Items As outlook.Items
Dim Items2 As outlook.Items
Dim sFilter As String
Dim sSubject As String
Set Olook = New outlook.Application
Sheet1.Range("A2").Select
Do Until ActiveCell.Value = "" ' Loop over cells containing subjects
'Checking the inbox
Set ItemsRaw = Olook.Session.GetDefaultFolder(olFolderInbox).Items
Debug.Print "Raw counts"
Debug.Print " ItemsRaw.Count: " & ItemsRaw.Count
'Checking the sent items
Set Items2Raw = Olook.Session.GetDefaultFolder(olFolderSentMail).Items
Debug.Print " Items2Raw.Count: " & Items2Raw.Count
sSubject = ActiveCell.Value
sFilter = "[Subject] = '" & sSubject & "'"
Debug.Print
Debug.Print sFilter
Debug.Print "Subject counts"
Set Items = ItemsRaw.Restrict(sFilter)
Debug.Print " Items.Count: " & Items.Count
Set Items2 = Items2Raw.Restrict(sFilter)
Debug.Print " Items2.Count: " & Items2.Count
Items.Sort "SentOn", True
Items2.Sort "SentOn", True
If Items.Item(1).ReceivedTime > Items2.Item(1).ReceivedTime Then
If TypeOf Items.Item(1) Is MailItem Then
Debug.Print Items.Item(1).Subject
With Items.Item(1).ReplyAll
.Display
.To = "XXX#noplacenowhere.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "Most recent item is not a mailitem:" & vbLf & "'" & sSubject & "'"
End If
Else
If TypeOf Items2.Item(1) Is outlook.MailItem Then
Debug.Print Items2.Item(1).Subject ' Print on Immediate Window
With Items2.Item(1).ReplyAll
.Display
.To = "XXX#noplacenowhere.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "Most recent item is not a mailitem:" & vbLf & "'" & sSubject & "'"
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
Debug.Print "Done."
End Sub
I am using below code to send email from excel when user press the button. it works fine. i actually want to fine tune this because right now what is happening is when in Column C there is a duplicate email and in column N it is all yes separate emails are generated. what i want to do is if there is a duplicate email in column C one email should be generated with subject and body from the duplicate rows
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
'On Error Resume Next
LastRow = Range("C" & Rows.Count).End(xlUp).Row
For Each Cell In Range("C8:C" & LastRow)
If WorksheetFunction.CountIf(Range("C8:C" & Cell.Row), Cell) = 1 Then
If Cells(Cell.Row, 14) = "Yes" Then
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & Cells(Cell.Row, 2) & vbNewLine & vbNewLine & _
Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & vbNewLine & _
"were issue to you for project " & Cells(Cell.Row, 8) & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
"This is a system generated email and doesn't require signature"
On Error Resume Next
With xOutMail
.To = Cells(Cell.Row, 3)
.CC = Cells(Cell.Row, 5)
.BCC = ""
.Subject = Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & " Issued to " & Cells(Cell.Row, 4)
.Body = xMailBody
'.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End If
End If
Next Cell
You can try:
Option Explicit
Public Sub Get_Unique_Count_Paste_Array()
Dim Ob As Object
Dim rng As Range
Dim LR As Long
Dim str As String
With Worksheets("Sheet1")
LR = .Range("C" & Rows.Count).End(xlUp).Row
Set Ob = CreateObject("scripting.dictionary")
For Each rng In .Range("C8:C" & LR)
str = Trim(rng.Value)
If Len(str) > 0 Then
Ob(str) = Ob(str) + 1
If Ob(str) = 1 Then '<= Check how many times email address appears in the array & if it s appears only one time then..
MsgBox str '<= Insert your code here
End If
End If
Next rng
End With
End Sub
I have to send reports to over 400 email addresses (on column B). The filepaths for each report are on columns C, D and E.
With this post: How to add default signature in Outlook the signature is added when the .display method is used.
The signature I want to show is for user number 1. I've selected the corresponding signature as a default signature for new messages.
This signature contains a picture, but this doesn't seem to cause any problems.
I wouldn't want the macro to show the mail every time it sends the mail, because I want to avoid the constant blinking on the screen.
I tried to look for something like "hide" method from here but didn't find anything useful (.display would run in the background, and it would stay hidden from the user). Other idea was to add application.screenupdating = false and correspondingly true in the end, but this didn't have any impact.
How could I display the email in the background without showing it every time to the user?
Sub sendFiles_weeklyReports()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim EmailCell As Range
Dim FileCell As Range
Dim rng As Range
Dim lastRow As Long
Dim timestampColumn As Long
Dim fileLogColumn As Long
Dim i As Long
Dim strbody As String
Dim receiverName As String
Dim myMessage As String
Dim reportNameRange As String
Dim answerConfirmation As Variant
Application.ScreenUpdating = False
Set sh = Sheets("Report sender")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createitem(0)
lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
i = 0
reportNameRange = "C1:E1"
timestampColumn = 17 'based on offset on EmailCell (column B)!
fileLogColumn = 18 'based on offset on EmailCell (column B)!
myMessage = "Are you sure you want to send weekly reports?" & vbNewLine & "'" & _
sh.Range("C2").Value & "', " & vbNewLine & "'" & sh.Range("D2").Value & "' and " & vbNewLine & _
"'" & sh.Range("E2").Value & "'?"
answerConfirmation = MsgBox(myMessage, vbYesNo, "Send emails")
If answerConfirmation = vbYes Then
GoTo Start
End If
If answerConfirmation = vbNo Then
GoTo Quit
End If
Start:
For Each EmailCell In sh.Range("B3:B" & lastRow)
EmailCell.Offset(0, fileLogColumn).ClearContents
EmailCell.Offset(0, timestampColumn).ClearContents
Set rng = sh.Cells(EmailCell.Row, 1).Range(reportNameRange)
If EmailCell.Value Like "?*#?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
With OutMail
For Each FileCell In rng
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then 'checks if there's a file path in the cell
.Attachments.Add FileCell.Value
EmailCell.Offset(0, fileLogColumn).Value = EmailCell.Offset(0, fileLogColumn).Value & ", " & _
Dir(FileCell.Value)
i = i + 1
End If
End If
Next FileCell
receiverName = EmailCell.Offset(0, -1).Value
strbody = "<BODY style=font-size:11pt;font-family:Calibri><p>Dear " & receiverName & ",</p>" & _
"<p>Please find attached the weekly reports.</p>" & _
"<p>Kind regards,</p></BODY>"
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.To = EmailCell.Value
.Subject = "Weekly Reporting – " & UCase("w") & "eek " & Format(Date, "ww") _
& " " & UCase(Left(Format(Date, "mmmm"), 1)) & Right(Format(Date, "mmmm"), _
Len(Format(Date, "mmmm")) - 1) & " " & Year(Now)
.display
.HTMLBody = strbody & .HTMLBody
.Send
EmailCell.Offset(0, timestampColumn).Value = Now
SkipEmail:
End With
Set OutMail = Nothing
End If
Next EmailCell
Set OutApp = Nothing
Application.ScreenUpdating = True
Call MsgBox("Weekly reports have been sent.", vbInformation, "Emails sent")
Quit:
End Sub
Appears .GetInspector has the same functionality of .Display except the "display".
Sub generateDefaultSignature_WithoutDisplay()
Dim OutApp As Object ' If initiated outside of Outlook
Dim OutMail As Object
Dim strbody As String
Dim receiverName As String
receiverName = const_meFirstLast ' My name
strbody = "<BODY style=font-size:11pt;font-family:Calibri><p>Dear " & receiverName & ",</p>" & _
"<p>Please find attached the weekly reports.</p>" & _
"<p>Kind regards,</p></BODY>"
Set OutApp = CreateObject("Outlook.Application") ' If initiated outside of Outlook
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.To = const_emAddress ' My email address
.Subject = "Weekly Reporting – " & UCase("w") & "eek " & Format(Date, "ww") _
& " " & UCase(Left(Format(Date, "mmmm"), 1)) & Right(Format(Date, "mmmm"), _
Len(Format(Date, "mmmm")) - 1) & " " & Year(Now)
' Default Signature
' Outlook 2013
' There is a report that .GetInspector is insufficient
' to generate the signature in Outlook 2016
'.GetInspector ' rather than .Display
' Appears mailitem.GetInspector was not supposed to be valid as is
' .GetInspector is described here
' https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.getinspector
Dim objInspector As Inspector
Set objInspector = .GetInspector
.HTMLBody = strbody & .HTMLBody
.Send
End With
ExitRoutine:
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
I would like to modify this script to include an attachment in the email that it creates. Cell F5 on worksheet "Instructions" contains the file path. I've tried to modify it using information from several different sources.
Here is a working version, pre-attachment attempts:
Sub CreateMails()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As String
Dim rngAttach As Range
Dim SigString As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With Worksheets("Data validation")
Set rngTo = .Range("J63")
Set rngSubject = .Range("J61")
strbody = "One time vendor number request." & vbNewLine & vbNewLine & _
"Thank you," & vbNewLine & vbNewLine & _
"__________________________________" & vbNewLine & _
.Range("J67") & vbNewLine & vbNewLine & _
"My Company" & vbNewLine & _
"123 Address street" & vbNewLine & _
"City, State, Zip, USA" & vbNewLine & _
"Telephone:"
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.Save
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set strbody = Nothing
Set rngAttach = Nothing
End Sub
All you should need is:
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.attachments.Add Range("F5").Value 'add the attachment
.Save
End With
Using your code, this worked for me.
Hi I can share the below template code which i use for creating and attaching a sheet from my workbook as a PDF _ i've changed some of the "text" values but the rest is the same.
You could work with this to include the attachment, and send as xlsx if required.
Sub SendWorkSheetToPDF()
Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim SH As Worksheet
Dim cell As Range
Dim strto As String
Dim Strcc As String
Application.ScreenUpdating = False
'To'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("A2:A15")
If cell.Value Like "?*#?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
On Error Resume Next
'CC'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("B2:B15")
If cell.Value Like "?*#?*.?*" Then
Strcc = Strcc & cell.Value & ";"
End If
Next cell
If Len(Strcc) > 0 Then Strcc = Left(Strcc, Len(Strcc) - 1)
On Error Resume Next
Set Wb = Application.ActiveWorkbook
FileName = "afilename"
xIndex = VBA.InStrRev(FileName, ".")
If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = FileName & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = strto
.CC = Strcc
.BCC = ""
.Subject = "subject text"
.Body = "All," & vbNewLine & vbNewLine & _
"Please see attached daily " & vbNewLine & vbNewLine & _
"Kind Regards" & vbNewLine & _
" "
.Attachments.Add FileName
.Send
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing
MsgBox "Email Sent"
End Sub