How to attach an Excel sheet to an Outlook email? - excel

I'm trying to fix one issue which is attaching a file.
I have a TABLE with list of people and their names and a condition(Y/N) column.
Column 1(Name) Column 2(Email) Column 3 (Condition Y/N)
I want to send emails to all people in the TABLE whose name matches with the unique values (name) in one of the columns in Sheet 1.
So I want something that looks up the column in Sheet 1 and maybe changes the Condition to Y in the TABLE for all unique names found in that Column in Sheet 1.(I can FILTER my TABLE in POWER QUERY to show only the rows with Condition "Y").
When the SINGLE email pops up (with the all people in the "To",) I want Sheet 1 or Sheet 2 to be attached to the email.
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table6").ListObject ' -> Set the table's name
On Error GoTo cleanup
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*#?*.?*" And _
LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please comply with the transfers in the attached file. " & _
"Look up for your store and process asap."
'You can add files also like this
'.Attachments.Add ("C:\test.txt") ' -> Adjust this path
.Display ' -> Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Code to Attach sheet 1 (doesn't work)
file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"
Worksheets("Sheet 1").Copy
ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
ActiveWorkbook.SaveAs Filename:= _
"H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1" & file_name_import, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Attachments.Add "H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1\" & file_name_import
I want to add code so my email pops up (with all required people in "To" and) with the attachment.

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Public Sub AttachFileToEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Dim strDir As String
Dim file_name_import As String
Dim fName As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
' Excel details not recreated, not needed for this question
file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"
' Subscript out of range error would be bypassed due to poor error handling
'Worksheets("Sheet 1").Copy
Worksheets("Sheet1").Copy
' Trailing backslash error would be bypassed due to poor error handling
'ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
strDir = "C:\Folder 1\Folder 2\Folder 3\Folder 4\"
Debug.Print strDir
' Backslash already at end of strDir
fName = strDir & "File 1" & file_name_import
Debug.Print fName
ActiveWorkbook.SaveAs FileName:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' Setup the email
Set OutMail = OutApp.CreateItem(0)
' Do not use On Error Resume Next without a specific reason for bypassing errors
' Instead fix the errors now that you can see them
With OutMail
' Excel details not recreated, not needed for this question
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please comply with the transfers in the attached file. " & _
"Look up for your store and process asap."
.Attachments.Add fName
.Display
End With
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

The idea here is to copy the sheet to a new file and save it in you temp folder. Then attach it to your email
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Attachment code based on: http://www.vbaexpress.com/kb/getarticle.php?kb_id=326
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim newBook As Workbook
Dim newBookName As String
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table1").ListObject
On Error GoTo Cleanup
' Save current file to temp folder (delete first if exists)
ThisWorkbook.Worksheets("Sheet1").Copy
Set newBook = ActiveWorkbook
newBookName = "AttachedSheet.xlsx"
On Error Resume Next
Kill Environ("temp") & newBookName
On Error GoTo 0
Application.DisplayAlerts = False
newBook.SaveAs Environ("temp") & newBookName
Application.DisplayAlerts = True
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*#?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
.Attachments.Add newBook.FullName ' -> Adjust this path
.Display ' -> Or use Display
End With
Set OutMail = Nothing
Cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Let me know if it works

Related

How to Loop Through A Table Column to Filter Another Table to Send Each Filtered Table By Email?

I am trying to:
Use a value from Table A (column - person's name) to filter on Table B in separate sheet
Copy filtered Table B into the body of an email (outlook)
Send outlook email to email address for that recipient (from Table A)
Loop through the process again for the next person in Table A
Example of Table A:
Example of Table B:
So for example for the first iteration
Take Dave Jones from Table A and filter Table B for Dave Jones.
Copy the filtered Table B to the body of a new email
Send to Dave Jones (davejones#davejones.com).
Return to Table A for the next entry, in this case Anne Smith, and do the same. Repeat until the end of Table A.
I made code for setting up an email but this takes the whole worksheet and does not do any filtering. I am unable to work out how to put this loop together for multiple emails:
Sub SendWorkSheet_SENDEMAILS1()
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
FileName = Wb.name & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
With OutlookMail
.to = "EMAIL ADDRESS HERE"
.CC = ""
.BCC = ""
.Subject = "Suppliers"
.HTMLBody = "Hi all," & "<br>" & "<br>" & "Please find attached etc. etc." & "<br>" & "<br>" & "Kind regards," & "<br>" & "<br>" & "Sender"
'.Body = ""
.Attachments.Add Wb2.FullName
.Display
'.Send
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub
I’ve had the need to do the task you describe a number of times in the past, and the following was the solution I came up with. Great credit to Sigma Coding at https://www.youtube.com/watch?v=ZlInSp0-MdU&ab_channel=SigmaCoding
for providing the bulk of the code – the Loop and Filter stuff I added for my own specific application.
For the following to work, you need to enable a couple of references within VBA. In the VBA Editor, select Tools/References & check the boxes ‘Microsoft Outlook 16.0 Object Library’ and ‘Microsoft Word 16.0 Object Library’. If they’re not already checked, you’ll find them listed alphabetically.
The following code suggestion assumes the following:
• The Managers’ list is on Sheet1 and the range they are contained in is called “MyRange”
• The table to filter is on Sheet2 and starts from cell A1
This code works for me – let me know how you go with it.
Option Explicit
Dim Outlook As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim OutInspect As Outlook.Inspector
Dim EmailTo As String
Dim OutWrdDoc As Word.Document
Dim OutWrdRng As Word.Range
Dim OutWrdTbl As Word.Table
Dim rng As Range, c As Range, MyRange As Range, myFilter As String
Sub TestEmail()
For Each c In Sheet1.Range("MyRange")
myFilter = c.Value
EmailTo = c.Offset(0, 1).Value
Sheet2.Range("A1:E1").AutoFilter Field:=2, Criteria1:="=" & myFilter
'ERROR TRAP
If EmailTo = "" Or Sheet2.Cells.SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then
GoTo Missing:
End If
Set rng = Sheet2.Cells.SpecialCells(xlCellTypeVisible)
On Error Resume Next
Set Outlook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set Outlook = New Outlook.Application
End If
Set OutMail = Outlook.CreateItem(olMailItem)
With OutMail
.To = EmailTo
.Subject = "Suppliers"
.Body = "Please find attached etc."
.Display
Set OutInspect = .GetInspector
Set OutWrdDoc = OutInspect.WordEditor
rng.Copy
Set OutWrdRng = OutWrdDoc.Application.ActiveDocument.Content
OutWrdRng.Collapse Direction:=wdCollapseEnd
Set OutWrdRng = OutWrdDoc.Paragraphs.Add
OutWrdRng.InsertBreak
OutWrdRng.PasteExcelTable Linkedtoexcel:=True, wordformatting:=True, RTF:=True
Set OutWrdTbl = OutWrdDoc.Tables(1)
OutWrdTbl.AllowAutoFit = True
OutWrdTbl.AutoFitBehavior (wdAutoFitWindow)
.Send
Application.CutCopyMode = False
Sheet2.AutoFilterMode = False
End With
Missing:
Next c
End Sub

Attach files to an email using Excel VBA

I am trying to save two worksheets in a workbook as separate files to company network locations and then attach those files to an email.
Sub Test_Module_Peter()
'
Dim OutApp As Object
Dim OutMail As Object
Dim SPpath As String
Dim SCpath As String
Dim SPfilename As String
Dim SCfilename As String
Dim SPFullFilePath As String
Dim SCFullFilePath As String
Dim wb As Workbook
Dim Cell As Range
Application.ScreenUpdating = False
' export a copy of PER SP Form
Sheets("PER SP").Select
Sheets("PER SP").Copy
' Remove formulas from SP sheet
With ActiveSheet.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
' Save a copy of the SP PER Form
SPpath = "\\UKRLTD008\Company\...\...\...\2019\"
SPfilename = "TEST - PER SP ABL90_2019 " & Range("M1")
SPFullFilePath = SPpath & SPfilename
ActiveWorkbook.SaveAs filename:=SPpath & SPfilename, FileFormat:=52
ActiveWorkbook.Close SaveChanges = True
' select ABL90 Credit Claim Master Spreadsheet
For Each wb In Application.Workbooks
If wb.Name Like "ABL90 Credit Claim Master*" Then
wb.Activate
End If
Next
' export a copy of PER SC Form
Sheets("PER SC").Select
Sheets("PER SC").Copy
' Remove formulas from SC sheet
With ActiveSheet.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
' Save a copy of the SC PER Form
SCpath = "\\UKRLTD008\Company\...\...\...\2019\"
SCfilename = "TEST - PER SC ABL90_2019 " & Range("M1")
SCFullFilePath = SCpath & SCfilename
ActiveWorkbook.SaveAs filename:=SCpath & SCfilename, FileFormat:=52
ActiveWorkbook.Close SaveChanges = True
' Send the SP PER Form to RMED
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "sales#radiometer.co.uk"
.To = "laura.valenti#radiometer.co.uk"
.CC = ""
.BCC = ""
.Subject = "RLTD PER Forms " & Range("M1")
.Body = "Hi " & vbNewLine & vbNewLine & "Please find attached ABL90 PER's" & vbNewLine & vbNewLine & "Thank you"
.Attachments.Add SPFullFilePath
.Attachments.Add SCFullFilePath
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
It saves the files, but when I try to add them as attachments to the email, the following error occurs:
Run-time error '-2147024894(80070002)': Cannot find this file. Verify the path and file name are correct.
I tried to save the path and filename together as FullFilePath for each file but it doesn't seem to work, can anyone tell me why?

Attach multiple files to Outlook email from a filtered list and loop [closed]

Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 4 years ago.
Improve this question
I have a list of customers with their invoice data (one customer may have one or more than one rows of data). I have assembled a macro script from multiple codes to filter out the customer (basis on email address) and send them a dunning letter with their account statement.
The code is working fine with email creation, except I am not able to attach their invoice copies listed in column 2 (In TempoWB workbook).
I think the problem is with Loop The code is jumping from Do while directly to .HTMLBody.It's skipping the previous codes to search and attach files. How can I fix it?
Here is the Zip file with all required data and files. In case you want to give it a try. Just copy the 'Renamed' invoice folder to C:\Invoices.
(customer names and other data has been altered for compliance reason)
Option Explicit
Sub Dunning_3_Populate_Emails_TempWB()
Application.ScreenUpdating = False
'This code populates emails to outlook as per the Credit analysts.
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim name_rg As Range
Dim name As String
Dim Subj As String
Dim irow As Integer
Dim dpath As String
Dim pfile As String
Dim strbody As String
Dim TempoWB As Workbook
'Folder location for Invoice copies
dpath = "C:\Invoices\Renamed"
'Column number to pick the invoices
irow = 2
Set OutApp = CreateObject("Outlook.Application")
name = Ash.Cells(name_rg.Row, 16)
Subj = Ash.Cells(name_rg.Row, 15)
Else
name = "email not found in Ash"
End If
------------------------------------------------------------------------------
'This portion has codes to filter the required data based on the unique email address
-----------------------------------------------------------------------------
'Create a new workbook with selected/ filtered data
rng.Copy
Set TempoWB = Workbooks.Add(1)
With TempoWB.Sheets(1)
.Cells(1).PasteSpecial
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
Columns("O:Q").Select
Selection.Delete Shift:=xlToLeft
On Error GoTo 0
'Location to save the temporary workbook
Application.DisplayAlerts = False
TempoWB.SaveAs Filename:="C:\Invoices\TempoWB.xlsx"
End With
'E-mail body for the dunning letters
strbody = "Hello " & name & "," & "<br>" & "<br>" & _
"<b>Below is the summary of your account and attached are the invoices:</b>" & "<br>" & "<br>"
On Error GoTo Cleanup
On Error Resume Next
With OutMail
.Display
.To = Cws.Cells(Rnum, 1).Value
.Subject = subj
Workbooks("TempoWB.xlsx").Activate
For irow = 2 To Lastrow
.Attachments.Add ("C:\Dunning Temp\" & Cells(irow, 2).Value & ".pdf")
Next
.HTMLBody = strbody & RangetoHTML(rng) & .HTMLBody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close TempoWB
Application.DisplayAlerts = False
Workbooks("TempoWB.xlsx").Close SaveChanges:=False
On Error Resume Next
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
End Sub
My initial suspicion of the row counter was just flat wrong. The problem turned out to be several small errors that simply caused the code to look for the attachment in places it could never find it.
Two things you should know:
1) The code currently in your question didn't feel right so I tossed it and went with the version you originally posted.
2) You need to update the path/directory strings and clear some comment blocks I've made. Nothing too difficult.
Option Explicit 'PO - Option Explicit, use it !
Sub Dunning_3_Populate_Emails()
Dim test1 As Long, test2 As Long
test1 = Timer
Application.ScreenUpdating = False
'This code populates emails to outlook.
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim SigString As String
Dim Signature As String
Dim name_rg As Range
Dim name As String
Dim Subj As String
Dim irow As Integer
Dim dpath As String
Dim pfile As String
Dim strbody As String
dpath = Environ("appdata") & "\VBA\Stack Overflow\Attachments" 'PO - my environment only, delete
' dpath = "C:\Invoices\Renamed" 'PO - original code, use if it is correct or modify
irow = 2
'looping through all the files and sending an mail
Set OutApp = CreateObject("Outlook.Application")
'C:\Users\<UserName>\AppData\Roaming\Microsoft\Signatures 'PO - not my edit, guessing it is here for reference
'----------------------------------------------------------------
'PO - blocked this off because it wasn't related to the problem
' should be perfectly ok to unblock
'----------------------------------------------------------------
' SigString = Environ("appdata") & _
' "\Microsoft\Signatures\My Signature.htm"
'
' If Dir(SigString) <> "" Then
' Signature = GetBoiler(SigString)
' Else
' Signature = ""
' End If
'
' On Error Resume Next
'
' With Application
' .EnableEvents = False
' .ScreenUpdating = False
' End With
'----------------------------------------------------------------
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:Q" & Ash.Rows.Count)
FieldNum = 17 'Filter column = B because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*#?*.?*" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
' ~ Search email address from Cws into Ash ~
Set name_rg = Ash.Columns(17).Find(Cws.Cells(Rnum, 1))
If Not name_rg Is Nothing Then
name = Ash.Cells(name_rg.Row, 16)
Subj = Ash.Cells(name_rg.Row, 15)
Else
name = "email not found in Ash"
End If
Set name_rg = Nothing
strbody = "Hello " & name & "," & "<br>" & "<br>" & _
"Hope you are fine!" & "<br>" & "<br>" & _
"I am writing to share the list of open invoice(s) on your account with <b>Keysight Technologies Inc.</b>" & "<br>" & "<br>" & _
"Please refer to th account statement below and let me know if you show any discrepancy on any of the open invoice(s), so that the required help can be arranged asap to get that resolved." & "<br>" & "<br>" & _
"Also, if the invoice(s) has been paid already, kindly share the payment details" & "<br>" & "<br>" & _
"<mark><i>** Please let me know if you have not recieved invoice copy so that I can arrange the invoice copy for you.</i></mark>" & "<br>" & "<br>" & _
"<b>Below is the summary of your account:</b>" & "<br>" & "<br>"
On Error GoTo Cleanup
On Error Resume Next
With OutMail
.To = Cws.Cells(Rnum, 1).Value
.Subject = Subj
'----------------------------------------------------------------
'PO - ranges and objects should be qualified to avoid bugs
' It is very likely Cells() was reading from the last active sheet (Cws)
'----------------------------------------------------------------
'Do While Cells(irow, 2) <> Empty 'PO - unqualified, dangerous
Do While Ash.Cells(irow, 2) <> Empty
'pikcing up file name from column B
'pfile = Dir(dpath & "\*" & Cells(irow, 2) & "*") 'PO - unqualified, dangerous
pfile = Dir(dpath & "\*" & Ash.Cells(irow, 2) & "*")
'checking for file exist in a folder and if its a pdf file
'If pfile <> "" And Right(pfile, 2) = "pdf" Then 'PO - a 2 letter string cannot equal a 3 letter string
If pfile <> "" And Right(pfile, 2) = "xt" Then 'PO - be sure to modify this
.Attachments.Add (dpath & "\" & pfile)
End If
'go to next file listed on the C column
irow = irow + 1
Loop
.HTMLBody = strbody & RangetoHTML(rng) & "<br>" & Signature
.Send
End With
' Set ws = Nothing 'PO - "ws" is undefied, probably "Cws"
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
Cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
test2 = Timer
MsgBox "All the Collection Letters have been sent and it took only " & Format((test2 - test1) / 86400, "hh:mm:ss") & " Seconds."
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
' TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 'PO forward slash is wrong syntax
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
Columns("O:Q").Select
Selection.Delete Shift:=xlToLeft
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
FileName:=TempFile, _
Sheet:=TempWB.Sheets(1).name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
And lastly, the nested while loops are the reason you started getting stuck in a loop. Reducing your code to illustrate the point, it looked something ike this:
Do While Cells(irow, 2) <> Empty
Do While Cells(irow, 2) = Empty
Loop
Loop
Both conditions will almost always be met so you get stuck on the inside loop if the cell is empty and you get stuck on the outside loop if the cell is populated.

How to assign Thisworkbook macro to Form control

I have a workbook to send out email reminders based on the due date. I would like to change it such that the macro will run when I click a button instead of running automatically when it is opened.
ThisWorkbook:
Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
Next ws
End Sub
Module1:
Option Explicit
Dim Bcell As Range
Dim iTo, iSubject, iBody As String
Dim ImportanceLevel As String
Public Sub CheckDates(ws As Worksheet)
For Each Bcell In Range("a4", Range("a" & Rows.Count).End(xlUp))
' if email column is not empty then command continues
If Bcell.Offset(0, 15) <> Empty Then
' mail will not be sent if current time is within 23.7 hours
' from time of mail last sent.
If Now() - Bcell.Offset(0, 49) > 0.9875 Then
If Bcell.Offset(0, 25) = Empty Then
If DateDiff("d", Now(), Bcell.Offset(0, 13)) = 7 Then
iTo = Bcell.Offset(0, 15)
iSubject = Bcell & " Due"
iBody = "<font face=""Calibri"" size=""3"">" & "Dear all,<br/><br/>" & _
"<u>FR No. " & Bcell & "</u><br/><br/>" & "Please be reminded that " & Bcell & " will be due by <b><FONT COLOR=#ff0000>" & _
Bcell.Offset(0, 13) & "</font></b>." & _
" Kindly ensure that the FR is closed by the due date and provide the draft FR report with preliminary investigation (Section B & D filled) to Quality.<br/><br/>" _
& "Thank you<br/><br/>" & "Best Regards,<br/>" & "Quality Department<br/><br/>" _
& "company Pte Ltd.<br/>" & "</font>"
SendEmail
Bcell.Offset(0, 49) = Now()
End If
End If
End If
End If
iTo = Empty
iSubject = Empty
iBody = Empty
Next Bcell
End Sub
Private Sub SendEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = iTo
.CC = "email#email.com"
.BCC = ""
.Subject = iSubject
.HTMLBody = iBody
.Importance = ImportanceLevel
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You have two ways to accomplish this depending on the type of button you want to use to run the macro:
a) If the button is a simply Shape (Insert > Shapes), you need to move the contents of Workbook_Open to a new sub within your Module1 (let's call it "trigger") and right-click the shape > Assign macro > "trigger".
Sub trigger()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
End If
Next ws
End Sub
b) If the button is not a shape but a form button, you need to double-click it while on the design view and move the contents of "trigger" to its own click sub (CommandButton1_click()).
c) Finally, remember to remove the contents of Workbook_Open() sub.

pause excel VBA until user saves a copy of a file

What is the correct syntax for pausing a VBA until the user saves an excel attachment? In the VB below the user is prompted upon opening the workbook with a selection, if that selection is yes then another message box appears asking them to fill out a form and save. I am trying to pause the VB until save is clicked. However, I am getting many compile errors currently. The lines with a ** ** were added to try and accomplish thisThank you :).
VB
Private Sub Workbook_Open()
Dim WS As Worksheet, Rng As Range, c As Range
Dim OutApp As Object, OutMail As Object
Dim Msg As String, Addr As String, FName As String, i As Long
Dim obj As Object
**Dim MyDoc As Document**
Dim MyFileCopy As String
Dim intAnswer As Integer
'define path
MyFileCopy = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form Attachment.xlsx"
'open sheet
Sheets("Email").Activate
intAnswer = MsgBox("Are there any issues to report", vbYesNoCancel)
Select Case intAnswer
Case vbYes
Range("D2").Value = "x"
MsgBox ("Please select an issue and save"), vbExclamation
'create a separate sheet2 to mail out and pause VB
Sheets(2).Copy
Set wkb = ActiveWorkbook
With wkb
**Set MyDoc = Documents.Add
MyDoc.SaveAs "MyFileCopy.xlsx"
DoEvents
Do
Loop Until MyDoc.Saved
.Close True**
End With
Case vbCancel
Application.SendKeys "%{F11}", True
Case Else
Range("C2").Value = "x"
End Select
'create connection, check condition, send email
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
With WS
Set Rng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
For Each c In Rng
Msg = "For " & WS.Cells(2, 2) & Chr(14) & Chr(14)
For i = 3 To 4
If LCase(WS.Cells(2, i)) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = c
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
If Range("D2").Value & Chr(14) = "x" Then .Attachments.Add MyFileCopy, 1
.Send
End With
Next c
Set OutMail = Nothing
Set OutApp = Nothing
'confirm message sent, clear sheet, and delete copy
MsgBox "The data has been emailed sucessfully.", vbInformation
Range("C2:D2").ClearContents
Kill MyFileCopy
'Exit and do not save
Application.Quit
ThisWorkbook.Close SaveChanges:=False
End Sub

Resources