• 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 copy to the body of the mail

Status
Not open for further replies.
Hello Experts,

I have set of columns as below:

73613

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.

Appreciate your help. Thank you in advance.
 

Attachments

  • Deal Info.xlsx
    10.2 KB · Views: 60
Last edited:
Like this?

Perfect !! Firstly, Thank you for looking into it !!
1. However, instead of a drop down list, can it be possible to trigger all emails to the unique owners in one go.
2. In the email the data is converting into text, which is causing the borders. (I mean borders are not complete). If possible can we paste a table ?

Thank you for the help in advance !!
 
Hi,

just wanted to check if you got a chance to look in the above scenario.

Appreciate your help. Thank you in advance.
 
Hi all,
here's my attempt:
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

  • Deal Info Keetoowah.xlsm
    21.5 KB · Views: 194
Hi Keetoowah,

I am getting error on below step, any idea what could be the reason.

Set list = CreateObject("System.Collections.ArrayList")
 
So if list is an Object variable then this ActiveX is missing on your Windows (or damaged), to see with your IT …​
 
Hi all,
here's my attempt:
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

Hi, extremely useful.

Would it be possible to attach the filtered data as an excel document instead of a table in the email body?
 
As a reminder the classic VBA Collection can be used rather than an external ActiveX like ArrayList, Dictionary, …​
 
Hello everybody,
as suggested by @Marc L, I publish an adapted version that uses a Collection instead of a Dictionary, it should solve the problems of MAC users
Code:
Sub mailKclct()
   '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, OutApp As Object
    Dim cel         As Range, myRng As Range
    Dim Itm         As Variant
    Dim LastRow     As Long
    Dim Dest        As String, strbody As String
    Dim collOwner   As New Collection
    
    Set Wks = ThisWorkbook.Sheets("Deal Info")
    
    On Error Resume Next
    For Each cel In Wks.Range("E2:E" & Range("E" & Rows.Count).End(xlUp).Row)
        collOwner.Add cel.Value, CStr(cel.Value)
    Next
    On Error GoTo 0
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    For Each Itm In collOwner
        
        Wks.Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=5, Criteria1:=Itm
        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
 
Hello Keetowah ! You should replace FSO too as on MAC any Windows ActiveX can't be used …​
 
Hello everyone again,
thanks to @Marc L for reporting my inattention, here is an updated version of the code that uses the ExcelSirJi function ConvertRangeToHTMLTable instead of the well known Ron de Bruin function RangetoHTML
Code:
Sub mailKclct2()
        '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, OutApp As Object
    Dim cel         As Range, myRng As Range
    Dim Itm         As Variant
    Dim LastRow     As Long
    Dim Dest        As String, strbody As String
    Dim collOwner   As New Collection
    
    Set Wks = ThisWorkbook.Sheets("Deal Info")
    
    On Error Resume Next
    For Each cel In Wks.Range("E2:E" & Range("E" & Rows.Count).End(xlUp).Row)
        collOwner.Add cel.Value, CStr(cel.Value)
    Next
    On Error GoTo 0
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    For Each Itm In collOwner
        
        Wks.Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=5, Criteria1:=Itm
        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 & ConvertRangeToHTMLTable(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
'Following function converts Excel range to HTML table
Public Function ConvertRangeToHTMLTable(rInput As Range) As String
'https://www.excelsirji.com/vba-code-to-convert-excel-range-into-html-table/

    'Declare variables
    Dim rRow As Range
    Dim rCell As Range
    Dim strReturn As String
    'Define table format and font
    strReturn = "<Table border='1' cellspacing='0' cellpadding='7' style='border-collapse:collapse;border:none'>  "
    'Loop through each row in the range
    For Each rRow In rInput.Rows
        'Start new html row
        strReturn = strReturn & " <tr align='Center'; style='height:10.00pt'> "
        For Each rCell In rRow.Cells
            'If it is row 1 then it is header row that need to be bold
            If rCell.Row = 1 Then
                strReturn = strReturn & "<td valign='Center' style='border:solid windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'><b>" & rCell.Text & "</b></td>"
            Else
                strReturn = strReturn & "<td valign='Center' style='border:solid windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'>" & rCell.Text & "</td>"
            End If
        Next rCell
        'End a row
        strReturn = strReturn & "</tr>"
    Next rRow
    'Close the font tag
    strReturn = strReturn & "</font></table>"
    'Return html format
    ConvertRangeToHTMLTable = strReturn
End Function
 
Hi all,
here's my attempt:
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
Hi all,
here's my attempt:
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

@Keetoowah Thanks for such a wonderful and understandable code. I was trying to attach the filtered Table in excel in mail attachment also along with mail body table. Can you please help us with editing in the above code.
 
Status
Not open for further replies.
Back
Top