VBA code to filter the data based on column and share the same in excel as attachment and on mail body

[GauravS313530]

Below is the macro for share the filtered data on Mail body but I am unable to modify this to share the same as excel attachment also along with on mail body.
I am new in VBA. please help.

>>> use code - tags <<<

Sub mailK()
    'https://chandoo.org/forum/threads/vba-to-filter-data-based-on-column-and-copy-to-the-body-of-the-mail.45912/

    Dim Wks    As Worksheet
    Dim OutMail As Object
    Dim OutApp As Object
    Dim myRng  As Range
    Dim list   As Object
    Dim item   As Variant
    Dim LastRow As Long
    Dim uniquesArray()
    Dim Dest   As String
    Dim strbody
   
    Set list = CreateObject("System.Collections.ArrayList")
    Set Wks = ThisWorkbook.Sheets("Deal Info")
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
   
    With Wks
        For Each item In .Range("E2", .Range("E" & .Rows.Count).End(xlUp))
            If Not list.Contains(item.Value) Then list.Add item.Value
        Next
    End With
   
    For Each item In list
       
        Wks.Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=5, Criteria1:=item
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
       
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        Set myRng = Wks.Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible)
       
        Dest = Cells(LastRow, "F").Value
        strbody = "Dear ," & "<br>" & _
                  "See the list of deals" & "<br/><br>"
       
        With OutMail
            .To = Dest
            .CC = ""
            .BCC = ""
            .Subject = "Deals"
            .HTMLBody = strbody & RangetoHTML(myRng)
            .Display
            '.Send
        End With
        On Error GoTo 0
    Next
   
    On Error Resume Next
    Wks.ShowAllData
    On Error GoTo 0
   
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
   
End Sub
Function RangetoHTML(myRng As Range)

    Dim TempFile As String
    Dim TempWB As Workbook
    Dim fso    As Object
    Dim ts     As Object
    Dim i      As Integer

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
       
        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    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

 

[Keetoowah]

Hi GauravS313530
try this code

Dim TempFile2 As String

Sub mailKxl()
'https://chandoo.org/forum/threads/vba-code-to-filter-the-data-based-on-column-and-share-the-same-in-excel-as-attachment-and-on-mail-body.49996/
    Dim OutApp As Object, OutMail As Object
    Dim myRng As Range, v As Variant
    Dim j As Long, lastRow As Long
    Dim strbody As String
    
    Application.ScreenUpdating = False

    lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:F" & lastRow).Value
    strbody = "Dear ," & "<br>" & _
                  "See the list of deals" & "<br/><br>"
                  
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For j = 2 To UBound(v)
            If Not .exists(v(j, 5)) Then
                .Add v(j, 5), Nothing
                With ActiveSheet
                    .Range("A1").AutoFilter 5, v(j, 5)
                    Set myRng = .Range("A1:C" & lastRow).SpecialCells(xlCellTypeVisible)
                    
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(j, 6)
                        .Subject = "Deals"
                        .HTMLBody = strbody & RangetoHTML(myRng)
                        .Attachments.Add TempFile2
                        .Display
                       ' .send
                    End With
                End With
            End If
        Next j
      
    End With
    
    Range("A1").AutoFilter
    
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(myRng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim i      As Integer
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    myRng.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
        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    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=")
    
    TempFile2 = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsx"
    
    With TempWB
    .SaveAs TempFile2
    .Close savechanges:=True
    End With
    
    Kill TempFile
          
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    Application.Wait Now + #12:00:01 AM#

End Function

 

[hsuresh666]

Hi

Can we add To , CC and Subject referring to the Cell values

 

[Keetoowah]

Hi hsuresh666,
the code was written to work on the file attached in the original request. If your requirement is different please open a new thread and include your sample file, also you have to explain exactly which cells you want to refer to.