VBA to email table range based on conditions

Ber93 

Hi Gabriel,

You’re welcome and glad that help 😀

Cheers!

Tony

gn00588950 

Tony, it's working now!

I changed my output from the database, so the date filter is pre-applied, and I also had replaced 0s in the "Resolved" field with "No", to make it more user-friendly. That is what was causing the error. I have removed the lines referencing the dates, and I replaced =0 with ="No", and it is working perfectly now.

I can't thank you enough! You're a genius.

Thanks,

Gabriel

Ber93 

Hi Gabriel,

Which line did the error return? I don’t think is related to the unique formula, because you already created another table for the mailing list

Did the survey table header name different from the code ?

I am referring column name : "Name", "Date" & "Resolved" in below code

    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

Thanks

Tony

gn00588950 

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?