Excel Dynamic filter Data Email through outlook using VBA

[VKMouli]

Dear Experts,
I am unable to attach filtered ledger as attachment for the respective employee but this code does filtered table & text inserted in outlook.
but i am looking attachment too. please suggest which parameter is missing on this.

Ledger Statement for the month of November-22				Total outstanding	7,59,890	INR			21-Nov-22
Vendor	Document Number	Reference	Document Date	Net due date	Amount in local currency	Local Currency	Text	Name	Email id (To)	Email id (Cc)
6003244	4530000341	CITI OTHERS	09-08-2022	09-08-2022	-8,000	INR	UPI CREDIT REFERENCE 222132718871	Prasad	Prasad@gmail.com	Kumar@gmail.com
6003244	4530000418	CITI OTHERS	09-09-2022	09-09-2022	-8,000	INR	UPI CREDIT REFERENCE 225275999048	Prasad	Prasad@gmail.com	Kumar@gmail.com
6003244	4530000431	CITI OTHERS	14-10-2022	14-10-2022	-8,000	INR	UPI CREDIT REFERENCE 228705675272	Prasad	Prasad@gmail.com	Kumar@gmail.com
6003244	4520000016	CITI-NEFT	05-04-2021	05-04-2021	52,500	INR	NEFT OUT UTR CITIN21152895522	Prasad	Prasad@gmail.com	Kumar@gmail.com
6003244	4520000518	CITI-NEFT	29-11-2021	29-11-2021	1,82,400	INR	NEFT OUT UTR CITIN21278028055	Prasad	Prasad@gmail.com	Kumar@gmail.com
6003247	4530000232	CITI-NEFT	27-07-2022	27-07-2022	3,57,610	INR	6003247 NEFT OUT UTR CITIN22310371351 TRF TO B VSS	Surya	Surya@gmail.com	Kumar@gmail.com
6003280	4530000324	CITI-NEFT	10-08-2022	10-08-2022	5,000	INR	NEFT OUT UTR S N V K SURESH BONAGIRI ADVANCE	Suresh	Suresh@gmail.com	Kumar@gmail.com
6006911	4530000231	CITI-NEFT	21-07-2022	21-07-2022	18,000	INR	6006911 NEFT OUT UTR CITIN22308001066 TRF TO VENKA	Kiran	Kiran@gmail.com	Kumar@gmail.com
6006911	4530000231	CITI-NEFT	21-07-2022	21-07-2022	68,000	INR	6006911 NEFT OUT UTR CITIN22307005986 TRF TO VENKA	Kiran	Kiran@gmail.com	Kumar@gmail.com
6006911	4530000338	CITI-NEFT	17-08-2022	17-08-2022	1,00,380	INR	NEFT OUT UTR CITIN22321398240 TRF TO MULTIMONEY FO	Kiran	Kiran@gmail.com	Kumar@gmail.com

Here is my Code below.

Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng As Range, i As Long, v As Variant
    v = Range("A2").CurrentRegion.Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = 3 To UBound(v)
            If Not .exists(v(i, 9)) Then
                .Add v(i, 9), Nothing
                With ActiveSheet
                    .Range("A2").AutoFilter 9, v(i, 9)
                    Set rng = .Range("A1", .Range("I" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(i, 10)
                        .Cc = v(i, 11)
                        .Subject = "Outstanding Advance-" & Format(Now, "MMMM-YY")
                        .HTMLBody = "Dear Sir, Please find outstanding advance details below. We request you to review & repay asap. This is a Monthly reminder for your infomration & action purposes only. Regards, Finance Dept." & "<br>" & RangetoHTML(rng)
                        .Display
                    End With
                End With
            End If
        Next i
    End With
    Range("A2").AutoFilter
    ActiveCell.Columns("A:I").EntireColumn.Select
    ActiveCell.Columns("A:I").AutoFit
    ActiveCell.Rows("1:10000").EntireRow.AutoFit
    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"
    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
    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
    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

 

[VKMouli]

i request you to please help us