• 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 for Excel Data in excel format to outlook email.

Status
Not open for further replies.
B

bijicha

Member
Hi Experts,

I need a macro to copy excel data based on filter all the Ns in one column then extract based on the the two digit initials in another column and send the email to each initial's email ID. Data should be in same excel format in email body. Email Subject should ne "Alert of - current date"

Attached excel file. Data filter with Column N all Ns, then copy the data A to O, based on each two alphabet initials in column H and send the email based on the second sheet.

Appreciate, some one can help me on this
 

Attachments

  • Master Task CM Tracking .xlsx
    102.9 KB · Views: 10
Hi bijicha,
here's a solution adapted from a previous message. If there is more than one person in a column, you must write exactly the same text in column A of the Email sheet and in column B both addresses separated by semicolons (for example AS/DD and AS@gmail.com;DD@gmail.com)

Code: 
Sub mailKclct3()
        'https://chandoo.org/forum/threads/vba-for-excel-data-in-excel-format-to-outlook-email.49654/
    
    Dim Wks         As Worksheet, WksMail As Worksheet
    Dim OutMail     As Object, OutApp As Object
    Dim cel         As Range, myRng As Range
    Dim Itm         As Variant
    Dim LastRow     As Long, LastRowMail As Long
    Dim Dest        As String, strbody As String
    Dim collAssign   As New Collection
    
    Set Wks = ThisWorkbook.Sheets("Listing OPEN CLOSED Tasks")
    Set WksMail = ThisWorkbook.Sheets("Email")
    
    On Error Resume Next
    For Each cel In Wks.Range("H3:H" & Range("H" & Rows.Count).End(xlUp).Row)
        collAssign.Add cel.Value, CStr(cel.Value)
    Next
    On Error GoTo 0
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    For Each Itm In collAssign
        
       With Wks.Range("A2:J" & Range("A" & Rows.Count).End(xlUp).Row)
        .AutoFilter Field:=10, Criteria1:="N"
        .AutoFilter Field:=8, Criteria1:=Itm
       End With
        
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        
        LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
        LastRowMail = WksMail.Cells(Rows.Count, "A").End(xlUp).Row
        Set myRng = Wks.Range("A2:O" & LastRow).SpecialCells(xlCellTypeVisible)
        
        Dest = Application.VLookup(Cells(LastRow, "H").Value, WksMail.Range("A2:B" & LastRowMail), 2, False)
              
        strbody = "Dear ," & "<br>" & _
                  "See the list of ..." & "<br/><br>" 'Adapt to your needs
                          
        With OutMail
            .To = Dest
            .CC = ""
            .BCC = ""
            .Subject = "Alert of " & Date
            .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 Keetoo,

Thank you very much for the swift action.. its working almost my requirement.. :)

I just changed the AutoFilter Field:=14 from 10, i need the "N" in column N.

Again another issue i faced was, few mails generating with blank data but only the headings. Can you check it one time and tell me how to avoid the blank data mails.
 
Hello @bijicha,:confused:
sorry for my distraction, please try the following correct version (the RangetoHTML function remains unchanged)
Code: 
Sub mailKclct4()
        'https://chandoo.org/forum/threads/vba-for-excel-data-in-excel-format-to-outlook-email.49654/
    
    Dim Wks         As Worksheet, WksMail As Worksheet
    Dim OutMail     As Object, OutApp As Object
    Dim cel         As Range, myRng As Range
    Dim Itm         As Variant
    Dim LastRow     As Long, LastRowMail As Long
    Dim Dest        As String, strbody As String
    Dim collAssign   As New Collection
    
    Set Wks = ThisWorkbook.Sheets("Listing OPEN CLOSED Tasks")
    Set WksMail = ThisWorkbook.Sheets("Email")
    
    With Wks.Range("A2:J" & Range("A" & Rows.Count).End(xlUp).Row)
    .AutoFilter Field:=14, Criteria1:="N"
    End With
    
    On Error Resume Next
    For Each cel In Wks.Range("H3:H" & Range("H" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        collAssign.Add cel.Value, CStr(cel.Value)
    Next
    On Error GoTo 0
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
        
    For Each Itm In collAssign
        
       With Wks.Range("A2:J" & Range("A" & Rows.Count).End(xlUp).Row)
        .AutoFilter Field:=8, Criteria1:=Itm
       End With
        
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        
        LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
        LastRowMail = WksMail.Cells(Rows.Count, "A").End(xlUp).Row
        Set myRng = Wks.Range("A2:O" & LastRow).SpecialCells(xlCellTypeVisible)
        
        Dest = Application.VLookup(Cells(LastRow, "H").Value, WksMail.Range("A2:B" & LastRowMail), 2, False)
              
        strbody = "Dear ," & "<br>" & _
                  "See the list of ..." & "<br/><br>" 'Adapt to your needs
                          
        With OutMail
            .To = Dest
            .CC = ""
            .BCC = ""
            .Subject = "Alert of " & Date
            .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
 
Hi Keetoo,

No worries :), i know you are helping lot of people around the world.

Thanks to you, Its working perfectly as my requirement.. Stay healthy and safe....
 
Hello everybody,
upon request I adapted the code to avoid writing any combination of initials/email addresses, assuming that for each line there could be one or two recipients:

Code: 
Sub mailKclct42()
        'https://chandoo.org/forum/threads/vba-for-excel-data-in-excel-format-to-outlook-email.49654/
    
    Dim Wks         As Worksheet, WksMail As Worksheet
    Dim OutMail     As Object, OutApp As Object
    Dim cel         As Range, myRng As Range
    Dim Itm         As Variant
    Dim LastRow     As Long, LastRowMail As Long
    Dim Dest        As String, Dest2 As String, strbody As String
    Dim collAssign   As New Collection
    Dim LenDest As Integer
    
    
    Set Wks = ThisWorkbook.Sheets("Listing OPEN CLOSED Tasks")
    Set WksMail = ThisWorkbook.Sheets("Email")
    
    With Wks.Range("A2:J" & Range("A" & Rows.Count).End(xlUp).Row)
    .AutoFilter Field:=14, Criteria1:="N"
    End With
    
    On Error Resume Next
    For Each cel In Wks.Range("H3:H" & Range("H" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        collAssign.Add cel.Value, CStr(cel.Value)
    Next
    On Error GoTo 0
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
        
    For Each Itm In collAssign
        
       With Wks.Range("A2:J" & Range("A" & Rows.Count).End(xlUp).Row)
        .AutoFilter Field:=8, Criteria1:=Itm
       End With
        
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        
        LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
        LastRowMail = WksMail.Cells(Rows.Count, "A").End(xlUp).Row
        Set myRng = Wks.Range("A2:O" & LastRow).SpecialCells(xlCellTypeVisible)
        
                
       Dest = Cells(LastRow, "H").Value
       LenDest = Len(Dest)
                
       Dest2 = IIf((LenDest = 2), Application.VLookup(Cells(LastRow, "H").Value, WksMail.Range("A2:B" & LastRowMail), 2, False), _
       Application.VLookup(Left(Cells(LastRow, "H").Value, 2), WksMail.Range("A2:B" & LastRowMail), 2, False) & ";" & _
       Application.VLookup(Right(Cells(LastRow, "H").Value, 2), WksMail.Range("A2:B" & LastRowMail), 2, False))
        
                    
        strbody = "Dear ," & "<br>" & _
                  "See the list of ..." & "<br/><br>" 'Adapt to your needs
                          
        With OutMail
            .To = Dest2
            .CC = ""
            .BCC = ""
            .Subject = "Alert of " & Date
            .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
 
:)Thanks Keetoo for the extended support, will check the code and let you know, i am travelling might be delay a week more..
 
Status
Not open for further replies.
Back
Top