I'm completely new to VBA, but I need to take care of automating something at work. I've followed a great Youtube tutorial by Chester Tugwell called "VBA to Automate Sending Email From Excel Table with Attachment from Folder", but instead of attaching an existing file, I need to add an Excel table as part of the email's body. The contents of the table need to be selected from an existing table in a separate file, based on a couple of conditions.
I have two files (attaching both). One is "Example MList" which is a mailing list, and the other is "Example Surveys", which contains a table with the content that needs to be in the email body. The trick is that each recipient should only receive the rows that are relevant to them. I need the body of each email to contain rows from the Surveys file, where the name of the case owner is equal to the recipient, the date of the case is >= than the date listed in the MList, and the Resolved field =0.
In the MList file, I've saved the VBA code I have from the Youtube tutorial, but the body part is what I'm having trouble with.
I'm attaching both example files too. This is what they look like
Mailing list
Table that needs to go in the email body based on recipient's conditions
This is the code I have so far
Sub EmailNegSurveys()
Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
Dim path As String
path = "C:" 'the file path
Dim RList As Range
Set RList = Range("A2", Range("a2").End(xlDown))
Dim R As Range
For Each R In RList
Set EItem = EApp.CreateItem(0)
With EItem
.To = R.Offset(0, 3)
.CC = R.Offset(0, 4)
.Subject = "Negative Surveys"
.Body = "" 'This should be a table from the file "Example Surveys", retrieving the rows where the Name matches the Recipient, the Date is >= "Date Start", and "Resolved"=0
.Display
End With
Next R
Set EApp = Nothing
Set EItem = Nothing
End Sub
Any help is much appreciated
Hi again Tony
I modified all the necessary parts and tried running it, but I get the error message "Subscript out of range". This is how I have the code. I added comments in the lines that I modified. Btw, this is how I have my columns in the mailing list table, just in case that is what's causing the problem.
Sub EmailNegSurveys()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
Dim I As Long
Dim Rec As String
Dim DateStart As Date
Dim SurveysWb As Workbook
Dim SurveysPath As String
SurveysPath = "example" 'my actual path
Set SurveysWb = Workbooks.Open(SurveysPath)
Dim SurveysSheet As Worksheet
Dim SurveysTable As ListObject
Set SurveysSheet = SurveysWb.Sheets("xOut_MailingNegSurveys") 'this is the named sheet in the file
Set SurveysTable = SurveysSheet.ListObjects("NegSurveys") 'named table
Dim MListSheet As Worksheet
Dim MListTable As ListObject
Set MListSheet = ThisWorkbook.Sheets("Distinct_mailing_list") 'name of the sheet where I am adding this sub
Set MListTable = MListSheet.ListObjects("MailingList") 'named table inside the NListSheet
For I = 2 To MListTable.ListRows.Count + 1
Rec = MListTable.Range(I, MListTable.ListColumns("Recipient").Index)
DateStart = MListTable.Range(I, MListTable.ListColumns("Date Start").Index)
SurveysTable.Range.AutoFilter Field:=SurveysTable.ListColumns("Name").Index, Criteria1:=Rec
SurveysTable.Range.AutoFilter Field:=SurveysTable.ListColumns("Date").Index, Criteria1:=">=" & DateStart, Operator:=xlAnd
SurveysTable.Range.AutoFilter Field:=SurveysTable.ListColumns("Resolved").Index, Criteria1:=0, Operator:=xlAnd
If SurveysTable.Range.SpecialCells(xlCellTypeLastCell).Row > 1 Then
Set EItem = EApp.CreateItem(0)
With EItem
.To = MListTable.Range(I, MListTable.ListColumns("Recipient Email").Index)
.CC = MListTable.Range(I, MListTable.ListColumns("Manager Email").Index)
.Subject = "Negative Surveys"
.HTMLBody = RangetoHTML(SurveysTable.Range.SpecialCells(xlCellTypeVisible))
.Display
End With
End If
Next
SurveysWb.Close
Set EApp = Nothing
Set EItem = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(rng As Range)
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"
'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
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
I'm thinking it might be because my mailing list table is a table I created using =IF(ISBLANK(A2),"",A2) and extended it like 500 rows. I did this because from A to G I have a dynamic array created using UNIQUE+FILTER. Since this VBA code requires an actual table, I created this table from I-N mirroring the dynamic array I have in A-G. Do you think this is what's causing the out of range error?
Accepted Solutions