Create Table from Data and Send Email

[Akshay_divecha]

Dear Experts,

i am new to macro and not able to think on how to write a macro which can perform below steps thus need your help

I have a excel which has 2 worksheets
Sheet1 - "Data" - This has list of Customers with their outstanding amount.
Sheet2 - " Details" - This has a list of Customs whom i need to send mail and their subject/mail body.

When a macro is initiated, it should perform below steps,

1. From Details sheet it should pick first row
2. Filter data for that customer in Data sheet, (Oldest first) add total in last row and copy, paste it in gmail also subject line, from/too/mail body should be copied from details sheet.
3. Send mail
4. do the same for all the customers mentioned in Details sheet

 

[Akshay_divecha]

Try:

Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim cust As Range, details As Worksheet, data As Worksheet, amt As Range, total As Double, x As Long, rng As Range
    Dim OutApp As Object, OutMail As Object
    Set details = Sheets("Details")
    Set data = Sheets("Data")
    x = data.Cells(data.Rows.Count, "D").End(xlUp).Row + 1
    Set OutApp = CreateObject("Outlook.Application")
    For Each cust In details.Range("A2", details.Range("A" & Rows.Count).End(xlUp))
        With data
            .Range("A1").CurrentRegion.AutoFilter 3, cust
            For Each amt In .Range("D2", .Range("D" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                total = total + amt.Value
            Next amt
            .Range("D" & x) = Format(total, "$#,##0.00")
            .Range("C" & x) = "Amount Due:"
            Set rng = .AutoFilter.Range
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = cust.Offset(, 1)
                .cc = cust.Offset(, 2)
                .Subject = cust.Offset(, 3)
                .HTMLBody = cust.Offset(, 4) & "<br><br>" & RangetoHTML(rng)
                .Display
            End With
            .Range("C" & x).Resize(, 2).ClearContents
        End With
    Next cust
    data.Range("A1").AutoFilter
    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

Thank you !!

 

[mumps]

You are very welcome.