Create Table from Data and Send Email

A

Akshay_divecha

Board Regular
Joined
Mar 11, 2014
Messages
70
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

Data Sheet.png
Details Sheet.png
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
record a macro to create your filter. here its FilterRecs()
then edit the macro to filter what you need.

then run sendGrpEmail()
this will take your filtered sheet and send it to the emails listed in the 'emails' worksheet

'paste this code into a module
Code: 
Option Explicit
Public gvFile
Sub FilterRecs()
Range("A1").Select
    ActiveSheet.UsedRange.Select
    Selection.AutoFilter
    ActiveSheet.UsedRange.AutoFilter Field:=2, Criteria1:="Arkham"
End Sub

Sub CopyData2Send()
' ExportData2eMail Macro
Dim wsNew As Worksheet
    gvFile = "C:\temp\file1email.xlsx"
  
    ActiveSheet.UsedRange.Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Set wsNew = ActiveSheet
  
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("A1").Select
    wsNew.Select
    wsNew.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=gvFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False      ', ConflictResolution:=True
     Application.DisplayAlerts = True
    ActiveWindow.Close
Set wsNew = Nothing
End Sub

Public Sub sendGrpEmail()
Dim vTO, vSubj, vBody
Const kbch = 5
Dim i As Integer
'get the filtered data
'CopyData2Send
gvFile = "C:\temp\file1email.xlsx"
  'get the target emails
Sheets("emails").Activate   'goto the email list
Range("B2").Select
vSubj = Range("D2").Value
vBody = Range("E2").Value
  'collect all emails
While ActiveCell.Value <> ""
    vTO = vTO & ActiveCell.Offset(0, 1).Value & ";" & ActiveCell.Offset(0, 2).Value & vbCrLf
  
    ActiveCell.Offset(1, 0).Select    'next row
Wend
'vSubj = "my subject"
'vBody = "my body"
  'send the file to target emails
Send1Email vTO, vSubj, vBody, gvFile
End Sub

Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library    REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application")  'not this
Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
  
    .HTMLBody = pvBody
    'If Not IsNull(pvBody) Then .Body = pvBody
  
    .Display True
    '.Send
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function

Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If
If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If
'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function
[\code]
 
Upvote 0
It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
ranman256 said:
record a macro to create your filter. here its FilterRecs()
then edit the macro to filter what you need.

then run sendGrpEmail()
this will take your filtered sheet and send it to the emails listed in the 'emails' worksheet

'paste this code into a module
Code: 
Option Explicit
Public gvFile
Sub FilterRecs()
Range("A1").Select
    ActiveSheet.UsedRange.Select
    Selection.AutoFilter
    ActiveSheet.UsedRange.AutoFilter Field:=2, Criteria1:="Arkham"
End Sub

Sub CopyData2Send()
' ExportData2eMail Macro
Dim wsNew As Worksheet
    gvFile = "C:\temp\file1email.xlsx"

    ActiveSheet.UsedRange.Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Set wsNew = ActiveSheet

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("A1").Select
    wsNew.Select
    wsNew.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=gvFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False      ', ConflictResolution:=True
     Application.DisplayAlerts = True
    ActiveWindow.Close
Set wsNew = Nothing
End Sub

Public Sub sendGrpEmail()
Dim vTO, vSubj, vBody
Const kbch = 5
Dim i As Integer
'get the filtered data
'CopyData2Send
gvFile = "C:\temp\file1email.xlsx"
  'get the target emails
Sheets("emails").Activate   'goto the email list
Range("B2").Select
vSubj = Range("D2").Value
vBody = Range("E2").Value
  'collect all emails
While ActiveCell.Value <> ""
    vTO = vTO & ActiveCell.Offset(0, 1).Value & ";" & ActiveCell.Offset(0, 2).Value & vbCrLf

    ActiveCell.Offset(1, 0).Select    'next row
Wend
'vSubj = "my subject"
'vBody = "my body"
  'send the file to target emails
Send1Email vTO, vSubj, vBody, gvFile
End Sub

Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library    REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application")  'not this
Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1

    .HTMLBody = pvBody
    'If Not IsNull(pvBody) Then .Body = pvBody

    .Display True
    '.Send
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function

Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If
If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If
'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function
[\code][
[/QUOTE]
Click to expand...
T
ranman256 said:
record a macro to create your filter. here its FilterRecs()
then edit the macro to filter what you need.

then run sendGrpEmail()
this will take your filtered sheet and send it to the emails listed in the 'emails' worksheet

'paste this code into a module
Code: 
Option Explicit
Public gvFile
Sub FilterRecs()
Range("A1").Select
    ActiveSheet.UsedRange.Select
    Selection.AutoFilter
    ActiveSheet.UsedRange.AutoFilter Field:=2, Criteria1:="Arkham"
End Sub

Sub CopyData2Send()
' ExportData2eMail Macro
Dim wsNew As Worksheet
    gvFile = "C:\temp\file1email.xlsx"
 
    ActiveSheet.UsedRange.Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Set wsNew = ActiveSheet
 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("A1").Select
    wsNew.Select
    wsNew.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=gvFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False      ', ConflictResolution:=True
     Application.DisplayAlerts = True
    ActiveWindow.Close
Set wsNew = Nothing
End Sub

Public Sub sendGrpEmail()
Dim vTO, vSubj, vBody
Const kbch = 5
Dim i As Integer
'get the filtered data
'CopyData2Send
gvFile = "C:\temp\file1email.xlsx"
  'get the target emails
Sheets("emails").Activate   'goto the email list
Range("B2").Select
vSubj = Range("D2").Value
vBody = Range("E2").Value
  'collect all emails
While ActiveCell.Value <> ""
    vTO = vTO & ActiveCell.Offset(0, 1).Value & ";" & ActiveCell.Offset(0, 2).Value & vbCrLf
 
    ActiveCell.Offset(1, 0).Select    'next row
Wend
'vSubj = "my subject"
'vBody = "my body"
  'send the file to target emails
Send1Email vTO, vSubj, vBody, gvFile
End Sub

Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library    REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application")  'not this
Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
 
    .HTMLBody = pvBody
    'If Not IsNull(pvBody) Then .Body = pvBody
 
    .Display True
    '.Send
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function

Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If
If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If
'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function
[\code]
Click to expand...
This did not work, pls find my workbook below and help
 
Upvote 0
mumps said:
It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
Click to expand...
Hi,

File uploaded in drop box, pls help

www.dropbox.com

Book1.xlsx

Shared with Dropbox
www.dropbox.com www.dropbox.com

My requirement is as below,

"Details" worksheet contains list of customer to which i need to send mail.

So macro should pick Customer name from "Details" A row and then filter in "Data" C row add a total at the end of row

copy that table and send it as a text with formatting to the email id mentioned in "Details" B & C with subject and mail body in D & E
 
Last edited:
Upvote 0
I just noticed in your original post that you are using gMail and not Outlook. Although there is a method for using gMail, unfortunately, my experience involves using Outlook so I won't be able to help. If you can use Outlook instead of gMail, let me know and I will suggest a solution.
 
Upvote 0
mumps said:
I just noticed in your original post that you are using gMail and not Outlook. Although there is a method for using gMail, unfortunately, my experience involves using Outlook so I won't be able to help. If you can use Outlook instead of gMail, let me know and I will suggest a solution.
Click to expand...
Hi.. i have no issue to switch to outlook instead of gmail. Pl provide solution
 
Upvote 0
Try this macro. This will display each email so you can see them for your review which you can then send manually. If you want the macro to send them all without your review, change
VBA Code: 
.Display
to
VBA Code: 
.Send

VBA Code: 
Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim cust As Range, details As Worksheet, data As Worksheet, amt As Range, total As Double
    Dim OutApp As Object, OutMail As Object
    Set details = Sheets("Details")
    Set data = Sheets("Data")
    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
            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>" & Format(total, "$#,##0.00")
                .Display
            End With
        End With
    Next cust
    data.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
mumps said:
Try this macro. This will display each email so you can see them for your review which you can then send manually. If you want the macro to send them all without your review, change
VBA Code: 
.Display
to
VBA Code: 
.Send

VBA Code: 
Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim cust As Range, details As Worksheet, data As Worksheet, amt As Range, total As Double
    Dim OutApp As Object, OutMail As Object
    Set details = Sheets("Details")
    Set data = Sheets("Data")
    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
            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>" & Format(total, "$#,##0.00")
                .Display
            End With
        End With
    Next cust
    data.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you Sir...
This created emails with "Total amount" in it but the requirement is to add the table in mail along with total amount.. pls see below now read and should read image for understanding and pls help.

Now read
Now read.png


Should Read
Should read.png
 
Upvote 0
Try:
VBA Code: 
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
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

C
  • Solved
E-mail Sending Loop
Replies
5
Views
331
mumps
mumps
S
  • Solved
Split table and send per email
Replies
3
Views
112
Domenic
D
N
  • Question
macro to filter spreadsheet by customer code, send relevant data via email
Replies
2
Views
218
Peter_SSs
Peter_SSs
J
  • Question
Listbox not showing in sent email
Replies
1
Views
124
Micron
M
StephenC101
  • Question
Mac Excel macro help needed please
Replies
1
Views
294
jkpieterse
jkpieterse

Forum statistics

Threads
1,214,952
Messages
6,122,457
Members
449,083
Latest member
Ava19

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top