My code is looping through all rows except the last one. How can I fix it??
Sub Send_CPR_Expiration_Sites()
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim OutApp As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
' Create a new Outlook object
For iCounter = 4 To WorksheetFunction.CountA(Columns(1))
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
' Subject
strSubj = "Immediate Action Required: Out of Compliance for "
On Error GoTo dbg
' Create a new item (email) in Outlook
strbody = ""
SiteLead = Cells(iCounter, 41).Value
SafetyR = Cells(iCounter, 42).Value
SafetySR = Cells(iCounter, 43).Value
SafetySS = Cells(iCounter, 44).Value
SiteCode = Cells(iCounter, 6).Value
'Make the body of an email
strbody = "Dear " & SiteCode & " Team," & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "blah blah blah" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "Let us know if you have any questions. Thank you!"
strbody = strbody & vbCrLf
objOutlookMsg.To = SiteLead
objOutlookMsg.CC = SafetyR & ";" & SafetySR & ";" & SafetySS
objOutlookMsg.Importance = olImportanceHigh
objOutlookMsg.Subject = strSubj & SiteCode
objOutlookMsg.BodyFormat = 1
objOutlookMsg.Attachments.Add "C:\Users"
objOutlookMsg.Attachments.Add "C:\Users"
' 1 – text format of an email, 2 - HTML format
objOutlookMsg.Body = strbody
objOutlookMsg.Display
Next iCounter
dbg:
'Display errors, if any
If Err.Description <> "" Then MsgBox Err.Description
Set objOutlookMsg = Nothing
Set OutApp = Nothing
End Sub
For iCounter = 4 To WorksheetFunction.CountA(Columns(1))
If you had blanks in (eg) A1:A2 and data in A3:A20 then the loop is going to run from 4 to 18, not 4 to 20
This is a better way to set the end of the for loop:
For iCounter = 4 To Cells(rows.count, 1).End(xlUp).Row
Related
Hello Everyone i was wondering if anyone can help me resolve my problem., i have got code which i found from the net which is working absolutely perfect however only problem is that when there is more than one due date in the column it will send email each time instead of sending all due date and names in One email at same time. Names it is on column A, Expiry Date it is in column E, and email stamp as sent in Column F, below its the code.
Private Sub Workbook_Open()
Dim Email As String, Subj As String, Msg As String, wBox As String
Dim RowNo As Long, i As Long, ky As Variant, cad As Variant
Dim wsEmail As Worksheet, OutApp As Object, OutMail As Object, dic As Object
Set wsEmail = ThisWorkbook.Sheets("Tracker")
Set dic = CreateObject("scripting.dictionary")
With wsEmail
For RowNo = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(RowNo, "E") <> "" Then
If .Cells(RowNo, "F") = "" And .Cells(RowNo, "E") <> "" And .Cells(RowNo, "E") <= Date + 60 Then
If dic.exists(.Cells(RowNo, "F").Value) Then
dic(.Cells(RowNo, "A").Value) = dic(.Cells(RowNo, "A").Value) & RowNo & "|"
Else
dic(.Cells(RowNo, "A").Value) = RowNo & "|"
End If
End If
End If
Next
For Each ky In dic.keys
cad = Left(dic(ky), Len(dic(ky)) - 1)
cad = Split(cad, "|")
wBox = ""
dBox = ""
For i = 0 To UBound(cad)
wBox = wBox & " " & wsEmail.Cells(cad(i), "A")
dBox = wsEmail.Cells(cad(i), "E")
.Cells(cad(i), "F") = "Sent"
.Cells(cad(i), "G") = Environ("username")
.Cells(cad(i), "H") = "E-mail sent on: " & Now()
Next
On Error Resume Next
Set OutApp = GetObject("Outlook.Application")
On Error GoTo 0
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
Do: Loop Until Not OutApp Is Nothing
Set OutMail = OutApp.CreateItem(0)
With OutMail
Subj = wBox & Space(1) & "from will expire soon"
Msg = "Hi" & vbCrLf & vbCrLf _
& "This is an automated e-mail to let you know that" & wBox & Space(1) & " will expire as follow;" & vbCrLf & vbCrLf _
& "Expiry date:" & dBox & vbCrLf & vbCrLf & "Many Thanks " & vbCrLf _
& vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
.To = "Sent to"
.CC = ""
.BCC = ""
.Subject = Subj
.ReadReceiptRequested = False
.Body = Msg
.Display
End With
mystring = ("Email has been sent for below staff;") & _
vbCrLf & vbCrLf & ky
MsgBox mystring
Set OutApp = Nothing
Set OutMail = Nothing
Next
End With
End Sub
is there any way to do this?
This should get you started.
Read the code's comments and adjust it to fit your needs.
Private Sub SendEmails()
Dim trackerSheet As Worksheet
Set trackerSheet = ThisWorkbook.Worksheets("CTCTracker")
Dim lastRow As Long
lastRow = trackerSheet.Cells(trackerSheet.Rows.Count, "A").End(xlUp).Row
Dim trackerRange As Range
Set trackerRange = trackerSheet.Range("A5:A" & lastRow)
' Declare boolean to check if there are any expiring names
Dim anyExpiring As Boolean
Dim nameCell As Range
For Each nameCell In trackerRange
' Check: 1) There is a expiring date
' 2) Email not sent yet
' 3) Expiring date less than today + 60 días
If nameCell.Offset(0, 4).Value <> "" And _
nameCell.Offset(0, 5).Value = "" And _
nameCell.Offset(0, 4).Value <= Date + 60 Then
' Store names and expiring dates into array
Dim infoArray() As Variant
Dim counter As Long
ReDim Preserve infoArray(counter)
infoArray(counter) = Array(nameCell.Value, nameCell.Offset(0, 4).Value)
counter = counter + 1
' Stamp action log
nameCell.Offset(0, 5).Value = "Sent"
nameCell.Offset(0, 6).Value = Environ$("username")
nameCell.Offset(0, 7).Value = "E-mail sent on: " & Now()
' To be able to check later
anyExpiring = True
End If
Next nameCell
' Exit if there are not expiring contacts
If Not anyExpiring Then
MsgBox "There are not expiring contacts"
Exit Sub
End If
' Prepare message
Dim namesList As String
For counter = 0 To UBound(infoArray)
namesList = namesList & infoArray(counter)(0) & vbTab & vbTab & " | " & vbTab & vbTab & infoArray(counter)(1) & vbNewLine
Next counter
Dim emailBodyTemplate As String
emailBodyTemplate = "This is an automated e-mail to let you know that the following CTC will expire as follow:" & vbCrLf & vbCrLf & _
"Name" & vbTab & vbTab & vbTab & " | " & vbTab & vbTab & vbTab & " CTC Expiry date" & vbCrLf & _
"<namesList>" & vbCrLf & vbCrLf & _
"Many Thanks " & vbCrLf & _
vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
Dim emailBody As String
emailBody = Replace(emailBodyTemplate, "<namesList>", namesList)
' Start outlook (late bound)
Dim outApp As Object
On Error Resume Next
Set outApp = GetObject("Outlook.Applicatin")
On Error GoTo 0
' If outlook is not running, start an instance
If outApp Is Nothing Then Set outApp = CreateObject("Outlook.Application")
Do: Loop Until Not outApp Is Nothing
' Compose email
Dim outMail As Object
Set outMail = outApp.CreateItem(0)
With outMail
.To = "Sent to"
.CC = ""
.BCC = ""
.Subject = "CTC will expire soon"
.ReadReceiptRequested = False
.Body = emailBody
.Display
End With
' Display message to user
Dim staffMessage As String
staffMessage = ("Email has been sent for below staff")
MsgBox staffMessage
' Clean up
Set outApp = Nothing
Set outMail = Nothing
End Sub
Let me know if it works
How can I add bold, underline, text color, and other text formatting to this email?
Sub Send_CPR_Expiration_Sites()
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim OutApp As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
' Create a new Outlook object
For iCounter = 4 To WorksheetFunction.CountA(Columns(1))
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
' Subject
strSubj = "Immediate Action Required: Out of Compliance for "
On Error GoTo dbg
' Create a new item (email) in Outlook
strbody = ""
SiteLead = Cells(iCounter, 41).Value
SafetyR = Cells(iCounter, 42).Value
SafetySR = Cells(iCounter, 43).Value
SafetySS = Cells(iCounter, 44).Value
SiteCode = Cells(iCounter, 6).Value
'Make the body of an email
strbody = "Dear " & SiteCode & " Team," & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "blah blah blah" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "Let us know if you have any questions. Thank you!"
strbody = strbody & vbCrLf
objOutlookMsg.To = SiteLead
objOutlookMsg.CC = SafetyR & ";" & SafetySR & ";" & SafetySS
objOutlookMsg.Importance = olImportanceHigh
objOutlookMsg.Subject = strSubj & SiteCode
objOutlookMsg.BodyFormat = 1 ' 1–text format of an email, 2-HTML format
objOutlookMsg.Attachments.Add "C:\Users"
objOutlookMsg.Attachments.Add "C:\Users"
objOutlookMsg.Body = strbody
objOutlookMsg.Display
Next iCounter
dbg:
'Display errors, if any
If Err.Description <> "" Then MsgBox Err.Description
Set objOutlookMsg = Nothing
Set OutApp = Nothing
End Sub
I updated the code to this, but it is still only pulling the text inside the quotations instead of formatting the text. I'm not sure what is wrong! I appreciate the help!
They want me to add more detail to my post because it is mostly code so I am typing to fill in space. Not sure what else to fix in my code. Let me know what you think
Sub Send_CPR_Expiration_Sites()
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim OutApp As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem, html As String
' Create a new Outlook object
For iCounter = 4 To Cells(Rows.Count, 1).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
' Subject
strSubj = "Immediate Action Required: Out of Compliance for "
On Error GoTo dbg
' Create a new item (email) in Outlook
strbody = ""
SiteLead = Cells(iCounter, 41).Value
SafetyReg = Cells(iCounter, 42).Value
SafetySubReg = Cells(iCounter, 43).Value
SafetySpec = Cells(iCounter, 44).Value
SiteCode = Cells(iCounter, 6).Value
'Make the body of an email
strbody = "<b> Dear </b>" & SiteCode & " Team," & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "<p><b> Your site blah blah </b> blah blah" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "<u> blah blah </u>" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "blah blah blah" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "Let us know if you have any questions. Thank you!"
strbody = strbody & vbCrLf
objOutlookMsg.To = SiteLead
objOutlookMsg.CC = SafetyReg & ";" & SafetySubReg & ";" & SafetySpec
objOutlookMsg.Importance = olImportanceHigh
objOutlookMsg.Subject = strSubj & SiteCode
objOutlookMsg.Body = strbody
objOutlookMsg.BodyFormat = 2
'objOutlookMsg.HTMLBody = "<html><head></head><body>" & mailbody & "</body></html>"
objOutlookMsg.Attachments.Add "C:\Users
objOutlookMsg.Attachments.Add "C:\Users"
objOutlookMsg.Display
Next iCounter
dbg:
'Display errors, if any
If Err.Description <> "" Then MsgBox Err.Description
Set objOutlookMsg = Nothing
Set OutApp = Nothing
End Sub
Here's a basic example:
Sub Example()
Dim OutApp As Outlook.Application
Dim msg As Outlook.MailItem, html As String
Set OutApp = CreateObject("Outlook.Application")
Set msg = OutApp.CreateItem(olMailItem)
msg.BodyFormat = olFormatHTML
msg.Subject = "Hello"
html = "<p>Dear person,</p>"
html = html & "<p><b>Please</b> <u>read</u> <i>this</i> "
html = html & "<span style='background-color:#F00'>important</span> mail.</p>"
html = html & "<p><span style='font-size:24pt'>right away</span></p>"
msg.HTMLBody = html
msg.Display
End Sub
You must use either olFormatRichText or olFormatHTML to format the body of your message. I would recommend using HTML. You can then construct an HTML string and reference that as your message.
This post gives an excellent example for you:
VBA Excel Outlook Email Body Formatting
P.S. Sorry. I don't usually read comments because they are typically unhelpful. I only just now saw the comments before. Did you set this line as in the example?:
.HTMLBody = "<html><head></head><body>" & mailbody & "</body></html>"
You must set the HTMLbody property for html formatting, NOT the .body property. You can also put the <html></html> tags in the message body itself instead of wrapping it like the example. The <head></head> tags are optional.
this is my first time asking a question here, would really appreciate how i could remove the loop and run the macro line by line manually?
Sub Email()
Dim olApp As Object
Dim olMail As Object
Dim olRecip As Object
Dim iRow As Long
Dim Recip As String
Dim Subject As String
iRow = 2
Set olApp = CreateObject("Outlook.Application")
Do Until IsEmpty(Cells(iRow, 1))
Recip = Cells(iRow, 1).Value
Subject = Cells(iRow, 3).Value
Set olMail = olApp.CreateItem(0)
With olMail
Set olRecip = .Recipients.Add(Recip)
.Display
.CC = ""
.Subject = ""
.HTMLbody = "<html><body><p>Dear " & Cells(iRow, 2).Value & "," & "<br>" & "<br>" & "summary " & Cells(iRow, 3).Value & " summary" & Cells(iRow, 4).Value & "summary" & "<br>" & "<br>" & "summary" & "<br>" & "<br>" & "conclusion" & .HTMLbody
olRecip.Resolve
.Display
End With
iRow = iRow + 1
Loop
Set olApp = Nothing
Exit Sub
End Sub
comment your code
Sub Email() Dim olApp As Object Dim olMail As Object Dim olRecip As Object Dim iRow As Long Dim Recip As String Dim Subject As String
iRow = 2
Set olApp = CreateObject("Outlook.Application")
'If column A has more the 1 email, will send/display email 1 at a time
'Do Until IsEmpty(Cells(iRow, 1))
Recip = Cells(iRow, 1).Value
Subject = Cells(iRow, 3).Value
Set olMail = olApp.CreateItem(0)
With olMail
Set olRecip = .Recipients.Add(Recip)
.Display
.CC = ""
.Subject = ""
.HTMLbody = "<html><body><p>Dear " & Cells(iRow, 2).Value & "," & "<br>" & "<br>" & "summary " & Cells(iRow, 3).Value & " summary" & Cells(iRow, 4).Value & "summary" & "<br>" & "<br>" & "summary" & "<br>" & "<br>" & "conclusion" & .HTMLbody
olRecip.Resolve
.Display
End With
iRow = iRow + 1
'Msgbox to show email was sent or failed
'Loop
Set olApp = Nothing
Exit Sub
End Sub '
Are you trying to debug? I guess what you want to do is to press F8 to step into the code.
Hi I have all my clients email address in row A on my excel sheet Named "Email". I have created the code below so that a box pops up when I press a bottom on the sheet and I can type the subject, and a few body lines. I want to be able to send the same message to all my client. IE for promotion or if we had to shut the office unexpectedly ect. Can any one help please?
Private Sub CommandButtonSend_Click()
Dim Email_Subject, Email_Send_From, Email_Body1, Email_Body2, Email_Sig, Email_Twitter As String
Dim Mail_Object, Mail_Single As Variant
Dim emailrange As Range, cell As Range
Dim Email_Send_To As String
Set emailrange = Worksheets("Email").Range("A2:A4")
For Each cell In emailrange
Email_Send_To = Email_Send_To & "j" & cell.Value
Next
Email_Send_To = Mid(Email_Send_To, 2)
On Error Resume Next
Email_Subject = UserFormTemplate.TextBoxSubject.Text
Email_Send_From = "shaunha#coversure.co.uk"
Email_Body1 = UserFormTemplate.TextBoxLine1.Text
Email_Body2 = UserFormTemplate.TextBoxLine2.Text
Email_Sig = UserFormTemplate.TextBoxSig.Text
Email_Twitter = UserFormTemplate.TextBoxTwitter.Text
On Error GoTo debugs
Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.cc = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body1 & vbNewLine & Email_Body2 & vbNewLine & vbNewLine & "Shaun Harrison Insurance Consultant" & vbNewLine & "Tel: 0800 308 1022 / shaunha#coversure.co.uk" & vbNewLine & vbNewLine & Email_Twitter
.send
End With
debugs:
If Err.Description <> "" Then MsgBox Err.Description
End
End Sub
Sub SendySend()
With ActiveSheet
EndRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
RowCount = 4
For XCount = 4 To EndRow
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.application")
Dim olmail As Outlook.MailItem
Set olmail = olApp.CreateItem(olMailItem)
If Range("D" & RowCount).Value = "Yes" Then
olmail.To = Range("A" & RowCount).Value
olmail.Subject = Range("B" & RowCount).Value
olmail.Body = Range("C" & RowCount).Value
olmail.Send
Else
DontSend = 1 'This Doesn't do anything at all, it's just for clarity
End If
RowCount = RowCount + 1
Next
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