As an example, we need to automatically send the following table to different customers based on the data of nearly 7 days.

The raw data are as follows:

The details of the latest n days to be generated are as follows

The general idea is as follows: get mailbox - > process data - > generate excel - > generate Email

In the actual processing, when the more difficult Email adds data to the content, it can't copy the table directly. Be sure to convert the data to an htm before you can add it.

The specific code is as follows:

Const d_Span = 7

Sub AutoEmail_Html()
'---------------Define Workbook------------------------------
Dim Dic As Object, Pin$, key, k
Dim c_Date As Date, b_Date As Date
Dim arr, brr
Dim wb As Workbook
'---------------Define Outlook-------------------------------
Dim wbStr As String, nlist As String
Dim OutlookApp As Outlook.Application
Dim OutlookItem As Outlook.MailItem
Dim newMail
Dim strAdr$
'=============================================================
Application.ScreenUpdating = False
arr = Sheet1.UsedRange        'Raw data
'Date interval
c_Date = Date: b_Date = c_Date - d_Span
Set Dic = CreateObject("Scripting.Dictionary")
'Get name+Email,For file looping
For i = 2 To UBound(arr)
    Pin = arr(i, 2)
    If Not Dic.Exists(Pin) And Pin <> "" Then Dic(Pin) = arr(i, 22)
Next i
key = Dic.keys
'----------------Process Data----------------------------------
For k = 0 To UBound(key)
    Pin = key(k)    'PIN
    brr = Get_Data_From_Array(arr, Pin, c_Date, b_Date)
    If Not IsArray(brr) Then Exit Sub
    'Create a new sheet to Email Enclosure
    Set wb = Workbooks.Add
    wb.Sheets(1).[A1].Resize(UBound(brr), UBound(brr, 2)) = brr
    wb.SaveAs ThisWorkbook.Path & "\" & Pin & ".xlsx"
    wbStr = wb.FullName
    wb.Close
    strAdr = ThisWorkbook.Path & "\" & Pin
    '---------------run OUTLOOK EMAIL------------------------------
    Set OutlookApp = New Outlook.Application
    Set OutlookItem = OutlookApp.CreateItem(olMailItem)
        With OutlookItem
            .Subject = "Remind you to hit the line!"
            .BodyFormat = Outlook.OlBodyFormat.olFormatHTML    'Add table content must be set to HTML format
            .HTMLBody = RangeToHTML(brr, strAdr)     'Array Turn to HTML Content
            .Display
            Set myAttachments = OutlookItem.Attachments
                myAttachments.Add wbStr, olByValue, 1, "workbook"
            .to = Dic(Pin)
            .Save
        End With
    Set OutlookItem = Nothing
Next k
Application.ScreenUpdating = True
'-----------------------Release Memory-------------------------------
Set OutlookApp = Nothing
Set Dic = Nothing
End Sub

'about EXCEL turn Html，Not open R1C1 Format, otherwise error will occur
Public Function RangeToHTML(rng, sAddress$)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim uRng
    TempFile = sAddress & ".htm"

'    rng.Copy
    'New file, save as html
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1, 1).Resize(UBound(rng), UBound(rng, 2)) = rng
        .Cells.Columns.AutoFit
'        .UsedRange.Copy
'        .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 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=")

    TempWB.Close savechanges:=False
'Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

'Get relevant data
Function Get_Data_From_Array(arr, ByVal Pin$, c_Date, b_Date)
Dim i, m
Dim Sk$
Dim x_Date As Date
Dim out(1 To 100, 1 To 9)
m = 1: i = 1
'Title
out(m, 1) = arr(i, 1)
out(m, 2) = arr(i, 2)
out(m, 3) = arr(i, 6)
out(m, 4) = arr(i, 9)
out(m, 5) = arr(i, 10)
out(m, 6) = arr(i, 13)
out(m, 7) = arr(i, 11)
out(m, 8) = arr(i, 12)
out(m, 9) = arr(i, 14)
For i = 2 To UBound(arr)
    Sk = arr(i, 2)      'PIN
    If Sk = Pin Then
        x_Date = String_2_Date(arr(i, 1))  'Date
        If x_Date <= c_Date And x_Date >= b_Date Then
            m = m + 1
            out(m, 1) = arr(i, 1)
            out(m, 2) = arr(i, 2)
            out(m, 3) = arr(i, 6)
            out(m, 4) = arr(i, 9)
            out(m, 5) = arr(i, 10)
            out(m, 6) = arr(i, 13)
            out(m, 7) = arr(i, 11)
            out(m, 8) = arr(i, 12)
            out(m, 9) = arr(i, 14)
        End If
    End If
Next i
If m = 1 Then Exit Function
Get_Data_From_Array = out
End Function
'Character date conversion character date format
Function String_2_Date(ByVal Str$) As Date
    a = Format(Str, "####-##-##")
    b = CDate(a)
    String_2_Date = b
End Function

Specific files can be downloaded from the following network disk

https://pan.baidu.com/s/1f29b4C3lFpyh4dQ8xVxIbw