• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA to filter data based on column and attach filtered data as excel file to email

C

CryonicBobcat

New Member
Hello,

Repost from original thread 05/03/2021 (1) VBA to filter data based on column and copy to the body of the mail | Chandoo.org Excel Forums - Become Awesome in Excel

"I want data to be filtered with column D (Deal Owner) and copy the filtered data (only column A, B & C) to the body of the email as a table and send mail to email address in column 'F'. In simple need to filter data with unique deal owner and send mail as a table to the respective owner"

I'm looking to perform the same task. However, instead of copying the filtered data into the body of the email, I would like to attach the filtered data as an excel file. Keetoowah has kindly provided the following code (below) - I'm struggling to edit this so that the data is attached as an excel file.

Hope someone can help

Code:
>>> use code - tags <<<
Code: 
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
 

Attachments

Last edited by a moderator:
Hi CryonicBobcat,
I was looking forward to your request;)
Try this code
Code: 
Sub CreateEmailsExcel()
'https://chandoo.org/forum/threads/vba-to-filter-data-based-on-column-and-attach-filtered-data-as-excel-file-to-email.49428/

    Dim targetWorkbook As Workbook
    Dim objFSO      As Object
    Dim varTempFolder As Variant, v As Variant
    Dim OutApp      As Object, OutMail As Object, rng As Range, i As Long
    Dim AttFile     As String
    v = Range("A2").CurrentRegion.Value
    
    Set OutApp = CreateObject("Outlook.Application")
    Application.ScreenUpdating = False
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    varTempFolder = objFSO.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss")
    objFSO.CreateFolder (varTempFolder)
    
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(v)
            If Not .exists(v(i, 6)) Then
                .Add v(i, 6), Nothing
                With ActiveSheet
                    .Range("A1").AutoFilter 6, v(i, 6)
                    Set rng = .AutoFilter.Range
                    Set targetWorkbook = Workbooks.Add
                    .UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
                    AttFile = v(i, 5) & ".xlsx"
                    
                    With targetWorkbook
                        .ActiveSheet.Columns.AutoFit
                        .SaveAs varTempFolder & "\" & AttFile
                        .Close
                    End With
                    
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(i, 6)
                        .Subject = ""
                        .HTMLBody = "test"
                        .Attachments.Add varTempFolder & "\" & AttFile
                        .Display
                        ' .Send
                    End With
                End With
            End If
        Next i
    End With
    Range("A1").AutoFilter
    
    With objFSO
        .deletefile varTempFolder & "\*.*", True
        .DeleteFolder varTempFolder
    End With
    
    Application.ScreenUpdating = True
End Sub
 
Keetoowah said:
Hi CryonicBobcat,
I was looking forward to your request;)
Try this code
Code: 
Sub CreateEmailsExcel()
'https://chandoo.org/forum/threads/vba-to-filter-data-based-on-column-and-attach-filtered-data-as-excel-file-to-email.49428/

    Dim targetWorkbook As Workbook
    Dim objFSO      As Object
    Dim varTempFolder As Variant, v As Variant
    Dim OutApp      As Object, OutMail As Object, rng As Range, i As Long
    Dim AttFile     As String
    v = Range("A2").CurrentRegion.Value
   
    Set OutApp = CreateObject("Outlook.Application")
    Application.ScreenUpdating = False
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    varTempFolder = objFSO.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss")
    objFSO.CreateFolder (varTempFolder)
   
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(v)
            If Not .exists(v(i, 6)) Then
                .Add v(i, 6), Nothing
                With ActiveSheet
                    .Range("A1").AutoFilter 6, v(i, 6)
                    Set rng = .AutoFilter.Range
                    Set targetWorkbook = Workbooks.Add
                    .UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
                    AttFile = v(i, 5) & ".xlsx"
                   
                    With targetWorkbook
                        .ActiveSheet.Columns.AutoFit
                        .SaveAs varTempFolder & "\" & AttFile
                        .Close
                    End With
                   
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(i, 6)
                        .Subject = ""
                        .HTMLBody = "test"
                        .Attachments.Add varTempFolder & "\" & AttFile
                        .Display
                        ' .Send
                    End With
                End With
            End If
        Next i
    End With
    Range("A1").AutoFilter
   
    With objFSO
        .deletefile varTempFolder & "\*.*", True
        .DeleteFolder varTempFolder
    End With
   
    Application.ScreenUpdating = True
End Sub
Click to expand...

Keetoowah you are awesome, all working exactly as described. Thank you very much.
 
You must log in or register to reply here.
Back
Top