VBA to email table range based on conditions

Ber93 

Here we go Gabriel,

First of all, we need to add an extra function to copy Table to Email body, the function are reference from: https://stackoverflow.com/questions/70921224/macro-to-copy-visible-cells-from-excel-to-email-body

The function code is here, you can paste after End sub of your original code

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

 After added this function, you can paste the following code to your Sub

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 = "C:\Users\Yau\Desktop\Example Surveys.xlsx"
Set SurveysWb = Workbooks.Open(SurveysPath)

Dim SurveysSheet As Worksheet
Dim SurveysTable As ListObject
Set SurveysSheet = SurveysWb.Sheets(1)
Set SurveysTable = SurveysSheet.ListObjects("Table1")

Dim MListSheet As Worksheet
Dim MListTable As ListObject
Set MListSheet = ThisWorkbook.Sheets(1)
Set MListTable = MListSheet.ListObjects("Table1")

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
    SurveysTable.AutoFilter.ShowAllData
Next

SurveysWb.Close
Set EApp = Nothing
Set EItem = Nothing

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

The code run as following logic:

1. Open the Survey Workbook, target the Table1 in Sheets1

2. Loop MList Table from Table1 Row 2 to last row (Since Row 1 is header)

3. Filter Survey Table1 by name, date and resolved

4. If filtered row more than 1 row (Header count as 1), means it have something to notify

5. Copy the table with header to Email

6. Display the email for you

Hope this help 🙂

Regards

Tony