I have got a workbook with 4 sheets:
1st - recipients email data such as TO, CC, Subject, from 2nd to 4th
the sheets which I need to send as an attachment to the recipients.
I made up the following script. But I faced 2 issues as a VBA beginner:
The 'loop' proposes for sending the 1st empty row from the 1st sheet
as well (I would like to stop with the last email details);
The 'ActiveWorkbook' sends all sheets (I would like to skip the 1st
one where the recipients & the VBA script are located);
I appreciate every advice/remark because I have been studying VBA for 3 months.
Thank you in advance!
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
End Sub
Have a look at this. This takes a copy of your workbook and saves it to the users "temp" location. It then does the modifications that you want to the copy of the workbook before attaching that.
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
Dim wb As Workbook, nwb As Workbook
Application.ScreenUpdating = False
Set wb = ThisWorkbook
wb.SaveCopyAs (Environ("temp") & "\temp_" & wb.Name)
Set nwb = Workbooks.Open(Environ("temp") & "\temp_" & wb.Name)
With nwb
Application.DisplayAlerts = False
' Delete relevant sheet
.Sheets(1).Delete
Application.DisplayAlerts = True
.Save
End With
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add nwb.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
nwb.Close
Application.ScreenUpdating = True
End Sub
Save a copy of your workbook
Open it
Remove the sheet from the copy
Save
Send this edited workbook
Related
I have a macro to draft automatic emails based on the recipients in each columns.
However, I'm looking for a code which can if the attachments named in the excel sheet are attached to the email. If there is any attachment missing from that email it should show a msg box with the name of the missing attachment.
SNip of one the sheets attached
Sub Email1()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
Dim FLNM As String
Dim AttchmentName As String
Set AddressList = Sheets("Tracker Summary").Range("Y:Z")
Dim AttchmentName1 As String
Dim path As String
Call FetchFileNames
path = ThisWorkbook.path & "/"
Dim i As Integer
i = 5
With olMail
ActiveSheet.Range("A1").Select
.BodyFormat = olFormatHTML
.Display
.To = ActiveSheet.Cells(2, i).Value
.CC = ActiveSheet.Cells(3, i).Value
.Subject = ActiveSheet.Cells(4, i).Value
.HTMLBody = ActiveSheet.Cells(5, i).Value & .HTMLBody
j = 6
Do Until IsEmpty(Cells(j, i))
On Error Resume Next
FLNM = ActiveSheet.Cells(j, i).Value
AttchmentName1 = Application.WorksheetFunction.VLookup(FLNM, AddressList, 1, True)
If FLNM = AttchmentName1 Then
AttchmentName = Application.WorksheetFunction.VLookup(FLNM, AddressList, 2, True)
.Attachments.Add AttchmentName
End If
j = j + 1
Loop
'.Display
End With
Sheets("Tracker Summary").Range("Y:Z").ClearContents
End Sub
Presuming that AttachmentName is a full file path string, maybe your code could check if the file exists beforehand.
For the sake of simplicity...
If Len(Dir(AttachmentName)) = 0 then msgbox "The File " & AttachmentName & " is missing"
... Just after you set AttachmentName value at AttchmentName = Application.WorksheetFunction.VLookup(FLNM, AddressList, 2, True)
Obviously, same for any other Attachment variables.
I have a button and macro currently set up that allows a sheet to save to a folder and close that sheet. Is there a way I can add to the macro so it will email out a message from Outlook saying something along the lines of "machine checklist submitted" to Test123#outlook.com for example. Below is the code i already have that works a treat.
Sub Saveworkbook()
Application.DisplayAlerts = False
Dim Sheet1 As Worksheet
Dim dName$, vName$, sName$
dName = Range("B8")
vName = ActiveWorkbook.FullName
sName = ActiveWorkbook.ActiveSheet.Name
For Each Sheet1 In ActiveWorkbook.Sheets
If Not Sheet1.Name = sName Then
Sheet1.Delete
End If
Next Sheet1
ActiveWorkbook.SaveAs "\\filestore\IT$\Forms and Templates\Completed Checklists\" & dName & "_" & Environ("username") & "_" & Format(Now, "ddmmyy")
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Thanks in advance
Sam
Add below to your code
dim olApp as object, olMail as object
set olApp = createobject("outlook.application")
set olMail = olApp.createitem(0)
With olMail
.To = "Test123#outlook.com"
.Cc = ""
.Bcc = ""
.Subject = "machine checklist submitted"
.body = "machine checklist submitted"
.Send
End With
set olApp = nothing
set olMail = nothing
I can send a single Outlook message using Excel VBA. However, I want to loop through my rows and send an email for each row that meets a certain condition.
Unfortunately, when I put the email code in a for loop only one email gets sent or none at all (depending on how I structure the code).
Is there something about calling Outlook multiple times that I should know?
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
For Each cell In contactRange
If Range(Cells(cell.Row, cell.Column).Address).Value = "Yes" Then
nextAddy = Range(Cells(cell.Row, cell.Column).Address).Offset(0, 5).Value
toAddy = nextAddy & ", " & toAddy
End If
Next cell
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2)
End If
For i = 0 To 1 'short loop for testing purposes
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next i
End Sub
Take the CreateObject line out of the loop:
Set OutApp = CreateObject("Outlook.Application")
For i = 0 To 1 'short loop for testing purposes
Set OutMail = OutApp.CreateItem(0)
...
I've tried to clean up your logic stream but there are many unanswered questions due to the lack of sample data, explicit error messages and output.
Private Sub CommandButton1_Click()
Dim outApp As Object
Dim outMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
With Worksheets(contactRange.Parent.Name) '<~~ surely you know what worksheet you are on..!?!
For Each cell In contactRange
If cell.Value = "Yes" Then 'no need to define a range by the range's address
nextAddy = cell.Offset(0, 5).Value 'again, no need to define a range by the range's address
toAddy = nextAddy & ";" & toAddy 'use a semi-colon to concatenate email addresses
End If
Next cell
End With
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2) 'I have no idea why you need to shorten the toAddy by 2
'only send mail where one or more addresses exist
For i = 0 To 1 'short loop for testing purposes
Set outMail = outApp.CreateItem(0)
With outMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set outMail = Nothing
Next i
End If
Set outApp = Nothing
End Sub
OK, so I re-wrote the code based on the feedback. I used a loop to send emails one at a time instead of concatenating the addresses together as I wanted to personalize each email. I also needed to create a form to handle the input as inputbox only accepts 256 characters.
A form was pretty much required as I needed to capture the subject line, message body, salutation, path the to the attachment etc.:
Private Sub CommandButton1_Click()
Dim subject As String, msg As String, path As String
subject = TextBox1.Value
msg = TextBox2.Value & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & TextBox4.Value & vbCrLf & TextBox5
path = TextBox3.Value
UserForm1.Hide
Module1.sendEmail subject, msg, path
End Sub
I placed the email code in Module1. Note, be sure to set the .sentOnBehalfOfName attribute or Outlook will simply pick an account which may not be the one you want if you have multiple accounts registered:
Public Sub sendEmail(subject As String, msg As String, path As String)
Dim outApp As Object
Dim outMail As Object
Dim contactRange As Range, cell As Range
Dim toAddy As String, emailMsg As String
Dim count As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Range("ContactYesNo")
With Worksheets("IT consulting")
For Each cell In contactRange
If cell.Value = "Yes" Then
count = count + 1
toAddy = cell.Offset(0, 6).Value
emailMsg = "Dear " & cell.Offset(0, 2).Value & "," & vbCrLf & vbCrLf & msg
Set outMail = outApp.CreateItem(0)
With outMail
.SentOnBehalfOfName = "me#someemail.com"
.To = toAddy
.CC = ""
.BCC = ""
.subject = subject
.Body = emailMsg
.Attachments.Add path
'.Display
.Send
End With
'log the action
cell.Offset(0, 1).Value = Now & vbCrLf & cell.Offset(0, 1).Value
End If
Set outMail = Nothing
Next cell
End With
Set outApp = Nothing
MsgBox "total emails sent: " & count
End Sub
Trying to send email through outlook but it is not saving the excel file and so it's not able to do attachment. Also my code is not able to pop up outlook window. It was working before but due to network drive it no longer works.
Sub Backup_required()
'coded by Atul , Vij
Dim OutlookApp, MItem As Object
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String
Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim wb As Workbook, wb2 As Workbook
Dim main_book As String
Dim newWorkbook As String
Application.DisplayAlerts = False
'create outblook object
Set OutlookApp = CreateObject("Outlook.Application")
Application.ScreenUpdating = False
'defines the user name
user = Environ("username")
main_book = ActiveWorkbook.Name
Set wb = Workbooks(main_book)
'email subject
Subj = "Blackline Reconciliation - Backup Required!"
'coded by Atul , Vij
Call pathDefinition
'operation for all sheets in BS_Download template with comments
For Each g In Workbooks(main_book).Worksheets
Set ws = wb.Worksheets(g.Name)
If g.Name <> "Sap Data" And g.Name <> "Automated BL Import" Then
lastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
'select every cells in all sheets in BS_Download template with comments
For Each a In ws.Range("W2:W" & lastRow)
If Left(a, 1) <> "*" And a.Value <> 0 And a.Offset(0, 1).Value = 0 Then
B = a.Row
f = a.Value
'add new book where the cell with met conditions are copied
Workbooks.Add
newWorkbook = ActiveWorkbook.Name
Workbooks(newWorkbook).Worksheets(1).Range("A1:AA1").Value = ws.Range("A1:AA1").Value
Set wb2 = Workbooks(newWorkbook)
Set ws3 = wb2.Worksheets(1)
'select all cells in all sheets in BS_Download template with comments
For Each d In Workbooks(main_book).Worksheets
If d.Name <> "Sap Data" And d.Name <> "Automated BL Import" Then
Set ws2 = wb.Worksheets(d.Name)
'compare if condition is met in all cells in all sheets in BS_Download template with comments
lastRow2 = ws2.Range("B" & Rows.Count).End(xlUp).Row
For Each e In ws2.Range("W2:W" & lastRow2)
C = e.Row
If e.Value = f And Left(e, 1) <> "*" And e.Offset(0, 1) = 0 Then
lastRow3 = ws3.Range("B" & Rows.Count).End(xlUp).Row + 1
ws3.Range("A" & lastRow3, "AA" & lastRow3).Value = ws2.Range("A" & C, "AA" & C).Value
e.Value = "*" & e.Value
If Left(a, 1) <> "*" Then
a.Value = "*" & a.Value
End If
End If
Next e
End If
'coded by Atul , Vij
Next d
ws3.Range("A1:AA1").Interior.Color = RGB(51, 102, 255)
ws3.Columns("A:AA").EntireColumn.AutoFit
'finally save the new opened workbook with name of compared a cell
wb2.SaveAs FileName:="D:\" & f & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wb2.Close
EmailAddr = f
'open new email
Set MItem = OutlookApp.CreateItem(olMailItem)
Set myAttachments = MItem.Attachments
With MItem
.To = EmailAddr
.Subject = Subj
.Display
End With
'paste the attachment of new workbooks save on user desktop
myAttachments.Add "D:\" & f & ".xlsx"
End If
Next a
End If
Next g
'erase the first left "*" in all the cell in T column
For Each a In Workbooks(main_book).Worksheets
Set ws = wb.Worksheets(a.Name)
If a.Name <> "Sap Data" And a.Name <> "Automated BL Import" Then
lastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
For Each B In ws.Range("W2:W" & lastRow)
If Left(B, 1) = "*" Then
B.Value = Right(B, (Len(B.Value) - 1))
End If
Next B
End If
Next a
Application.DisplayAlerts = True
End Sub
The problem is on this line (don't know what it could be with out a copy of the workbook):
If Left(A, 1) <> "*" And A.Value <> 0 And A.Offset(0, 1).Value = 0 Then
Changing that line to:
If True Then
And then changing:
f = A.Value
To:
f = "newbook"
Yields the following email being popped up for sending:
So there is no problem with your actual e-mail logic, just your workbook parsing logic.
Per updated comments
To automatically send the message change:
Set myAttachments = MItem.Attachments
With MItem
.To = EmailAddr
.Subject = Subj
.Display
End With
'paste the attachment of new workbooks save on user desktop
myAttachments.Add "D:\" & f & ".xlsx"
to:
Set myAttachments = MItem.Attachments
myAttachments.Add "D:\" & f & ".xlsx"
With MItem
.TO = EmailAddr
.Subject = Subj
.Display
.Send
End With
I think something like this work if you say MIem.send option
If GetOutlook = True Then
Set mItem = mOutlookApp.CreateItem(olMailItem)
mItem.Recipients.Add strRecip
mItem.Subject = strSubject
mItem.Body = strMsg
' This code allows for 1 attachment, but with slight ' modification, you could provide for multiple files.
If Len(strAttachment) > 0 Then
mItem.Attachments.Add strAttachment
End If
mItem.Save
mItem.Send
End If
I have a list of accounts and relevant information that I have to split up and send specific accounts to certain people. This has to be done about 50 times. I already have a program setup that will filter, copy the data to a new file, and save. Is there a way to set it up to then email this file based on a list of contacts?
Each account is covered by a region, so I have a list which has the region and the contact's email. In the macro that splits by the regions, it has an array of these regions so is some kind of lookup possible from the list of contacts?
Code:
Sub SplitFile()
Dim rTemp As Range
Dim regions() As String
Set rTemp = ThisWorkbook.Sheets("Combined").Range("AH2:AH1455")
regions = UniqueItems(rTemp, False)
For N = 1 To UBound(regions)
Set wb = Workbooks.Add
ThisWorkbook.Sheets("DVal").Copy _
after:=ActiveWorkbook.Sheets("Sheet1")
With ThisWorkbook.Sheets("Combined")
.AutoFilterMode = False
' .AutoFilter
.Range("A1:BP1455").AutoFilter Field:=34, Criteria1:=regions(N)
Application.DisplayAlerts = False
.Range("A1:BP1455").Copy wb.Sheets("Sheet1").Range("A1")
Application.DisplayAlerts = True
For c = 1 To 68
wb.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = .Columns(c).ColumnWidth
Next c
End With
With wb
.Sheets("Sheet1").Activate
.SaveAs Filename:="H:\" & regions(N) & " 14-12-11"
.Close True
End With
Set wb = Nothing
Next N
End Sub
I am assuming you want to do it programmaticaly using VB, you can do something like
Dim msg As System.Web.Mail.MailMessage = New System.Web.Mail.MailMessage()
msg.From = "noone#nobody.com"
msg.To = "someone#somewhere.com"
msg.Subject = "Email with Attachment Demo"
msg.Body = "This is the main body of the email"
Dim attch As MailAttachment = New MailAttachment("C:\attachment.xls")
msg.Attachments.Add(attch)
SmtpMail.Send(msg)
If you're having trouble with the above, my mail macro is different; this is used with excel 2007:
Sub Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "To Whom It May Concern:" & vbNewLine & vbNewLine & _
"This is a test!" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.to = "anyone#anywhere.com"
.cc = ""
.BCC = ""
.Subject = "This is only a test"
.Body = strbody
'You can add an attachment like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Jon
I am assuming the following.
1) Regions are in Col AH
2) Contacts are in Col AI
3) UniqueItems() in your code removes duplicates?
Please try the below code. I have commented the code so please go through them and make relevant changes. Especially to the part where you save the File. I have used Late Binding with Outlook.
NOTE: I always test my code before posting but in the current scenario I cannot so do let me know if you find any errors.
Option Explicit
Sub SplitFile()
'~~> Excel variables
Dim wb As Workbook, wbtemp As Workbook
Dim rTemp As Range, rng As Range
Dim regions() As String, FileExt As String, flName As String
Dim N As Long, FileFrmt As Long
'~~> OutLook Variables
Dim OutApp As Object, OutMail As Object
Dim strbody As String, strTo As String
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
'~~> Just Regions
Set rTemp = wb.Sheets("Combined").Range("AH2:AH1455")
'~~> Regions and Email address. We wil require this later
'~~> Tofind email addresses
Set rng = wb.Sheets("Combined").Range("AH2:AI1455")
regions = UniqueItems(rTemp, False)
'~~> Create an instance of outlook
Set OutApp = CreateObject("Outlook.Application")
For N = 1 To UBound(regions)
Set wb1 = Workbooks.Add
wb.Sheets("DVal").Copy after:=wb1.Sheets(1)
With wb.Sheets("Combined")
.AutoFilterMode = False
With .Range("A1:BP1455")
.AutoFilter Field:=34, Criteria1:=regions(N)
'~~> I think you want to copy the filtered data???
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy _
wb1.Sheets("Sheet1").Range("A1")
For c = 1 To 68
wb1.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = _
wb.Columns(c).ColumnWidth
Next c
End With
End With
'~~> Set the relevant Fileformat for Save As
' 51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
' 52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
' 50 = xlExcel12 (Excel Binary Workbook in 2007-2010 with or without macro's, xlsb)
' 56 = xlExcel8 (97-2003 format in Excel 2007-2010, xls)
FileFrmt = 52
Select Case FileFrmt
Case 50: FileExt = ".xlsb"
Case 51: FileExt = ".xlsx"
Case 52: FileExt = ".xlsm"
Case 56: FileExt = ".xls"
End Select
'~~> Contruct the file name.
flName = "H:\" & regions(N) & " 14-12-11" & FileExt
'~~> Do the save as
wb1.SaveAs Filename:=flName, FileFormat:=FileFrmt
wb1.Close SaveChanges:=False
'~~> Find the email address
strTo = Application.WorksheetFunction.VLookup(regions(N), rng, 2, 0)
'~~> Create new email item
Set OutMail = OutApp.CreateItem(0)
'~~> Create the body of the email here. Change as applicable
strbody = "Dear Mr xyz..."
With OutMail
.To = strTo
.Subject = regions(N) & " 14-12-11" '<~~ Change subject here
.Body = strbody
.Attachments.Add flName
'~~> Uncomment the below if you just want to display the email
'~~> and comment .Send
'.Display
.Send
End With
Next N
LetContinue:
Application.ScreenUpdating = True
'~~> CleanUp
On Error Resume Next
Set wb = Nothing
Set wb1 = Nothing
Set OutMail = Nothing
OutApp.Quit
Set OutApp = Nothing
On Error GoTo 0
Whoa:
MsgBox Err.Description
Resume LetContinue
End Sub