Question : Excel Emailing Worksheet

Hi Experts,

Hope someone can assist with this as I've spent most of two days trying to adjust this piece of code for emailing a worksheet based on a grouping code. I'm hoping it can be tweaked rather than changed entirely. Also, the more simplified the better (if possible) as I'm a newbie.

Data is inputted to the data sheet. There is a grouping code called region.

There is a distribution sheet which has the following fields: Region and Recipient. The region field from the data sheet is manuallly inputted into column A along with the recipients name. When the macro "SendItAll" is run, it copies the data from data sheet into the report sheet based on the grouping code in the distribution list and emails the worksheet to the named recipient.

The issues are:

when the worksheet is created for emailing it doesn't look like the report sheet as it loses formatting etc. Also the report sheet itself has to be re-formatted every time after the macro is run. how can i improve the code to eliminate this reformatting or missing data in rows 1 and 2 etc?

Secondly, when the worksheet is emailed how can I get written in the piece of code a standard line in the body of the message stating To (Recipient's Name) and "Please find attached the results" and Regards as the closing etc..

Sample FIle attached...Macro is called "Senditall"

Many thanks in advance

Attachments:

Results-Test.xlsm (115 KB) (File Type Details)

Sample File

Answer : Excel Emailing Worksheet

This code snippet uses Outlook object, to create a mail message which will be saved in your Drafts.

Change .Save to .Send to immediately send it but this might raise issues with your security settings.

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:



Public Sub SendItAll()
    
    Dim outlookApp
    Dim mItem
    Dim lRow As Long
    On Error Resume Next
    Set outlookApp = GetObject("", "Outlook.Application")
    If Err.Number <> 0 Then
        Set outlookApp = CreateObject("Outlook.Application", "")
    End If
    On Error GoTo 0
    Application.ScreenUpdating = Fase
    lRow = Worksheets("Data").Range("A65536").End(xlUp).Row
    ' Clear out any old data on Report
    Sheets("Report").Select
    Range("A4:AD" & lRow).ClearContents
    ' Sort data by region
    'Sheets("Data").Select
    'Range("A1").CurrentRegion.Select
    'Selection.Sort Key1:=Range("A2"), Header:=xlYes
    ' Process each record on Distribution
    Sheets("Distribution").Select
    FinalRow = Range("A50").End(xlUp).Row
    For i = 2 To FinalRow
        Sheets("Distribution").Select
        RegionToGet = Range("A" & i).Value
        Recipient = Range("B" & i).Value
        ' Clear out any old data on Report
        Sheets("Report").Select
        Range("A4:AD" & lRow).ClearContents
        ' Get records from Data
        Sheets("Data").Select
        Range("A1").CurrentRegion.Select
        ' Turn on AutoFilter, if it is not on
        If ActiveSheet.AutoFilterMode = False Then Selection.AutoFilter
        ' Filter the data to just this region
        Selection.AutoFilter Field:=1, Criteria1:=RegionToGet
        ' Select only the visible cells and copy to Report
        Selection.SpecialCells(xlCellTypeVisible).Select
        Selection.Copy Destination:=Sheets("Report").Range("A4")
        ' Turn off the Autofilter
        Selection.AutoFilter
        ' Copy the Report sheet to a new book and e-mail
        Sheets("Report").Copy
        ActiveWorkbook.SaveAs "C:\Windows\temp\book123.xls"
        
'        Application.Dialogs(xlDialogSendMail).Show _
'            arg1:=Recipient, _
'            arg2:="Report - " & RegionToGet
        Set mItem = outlookApp.CreateItem(olMailItem)
        With mItem
            .To = Recipient
            .Subject = "Report - " & RegionToGet
            .Body = "This is your report"
            .Attachments.Add "C:\Windows\temp\book123.xls"
            .Save
        End With
        ActiveWorkbook.Close SaveChanges:=False
        Kill "C:\Windows\temp\book123.xls"
        Application.ScreenUpdating = Fase
      
    Next i
End Sub