[Last Call] Learn about multicloud storage options and how to improve your company's cloud strategy. Register Now


Macro to Email Excel Worksheets Based on Cell References

Posted on 2014-03-20
Medium Priority
Last Modified: 2014-03-28
I've searched and searched, but can't quite find the right solution to do this.

I have an Income Statement Report that is an Excel Report where the Tabs are a different branches of our company. I have to then separate out certain tabs and copy and paste them into a new workbook and then email that workbook to a specific manager.

I would like to create a Macro that does this for me based on criteria that I provide. I.e. Have a Worksheet "EmailList" with the list of the Managers and which Tab/Worksheet they need to receive and then email it to them.

I know there are a few ways I would need to layout the "EmailList" and I'm not sure of the most efficient way so that the code is easy to write.

I've attached 2 files that represent the report with the 2 options for the "EmailList" Tab.

-ReportDistrubtionExample1 - Has the list of managers and the reports that they need listed out to the right of them. (The number of managers and reports would need to be dynamic and grow or shrink)

-ReportDistrubtionExample2 - This is more of a Database view where I have multiple rows. I would only want to send out 1 email/workbook per manager though.
Question by:thomas-sherrouse
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2

Expert Comment

ID: 39943394
it sounds like two parts?
1. generate a new workbook from a master (Excel) app that reads two books and writes data to the new one.
2. create a function (run from master) to create an Outlook object, attach the new workbook, and email it.

Author Comment

ID: 39943397
Yes - That is correct.

Expert Comment

ID: 39943424
coding the whole app will me too much time unfortunately, but the key functions are
CurWkbook.Worksheets(wkSheet.Name).Copy Before:=newWkbook.Sheets(1)

Function SendEmail(RecipEmail As String, Subject As String, BBody As String, cc1 As String) As Boolean
  On Error GoTo err_SendEmail
  Dim olApp As Outlook.Application
  ErrorLine = 7
  Dim oItem As Outlook.MailItem
  Dim tInterval As Integer, signature As String
  If RecipEmail <> "" Then
    SendEmail = False
    Set olApp = CreateObject("Outlook.Application")
    Set oItem = olApp.CreateItem(olMailItem)
    With oItem
      .To = RecipEmail & IIf(cc1 <> "", "; " & cc1, "")
      .Display   'to get signature for later use
      signature = Nz(DLookup("CurricCoordSignature", "tblPrograms_LOOKUP", "Prog_Num=" & Nz(Forms("frmMain").cboProgram, 0)), 0) '.Body
      .Subject = Subject
      .Body = BBody & vbCr & vbCr & signature
    End With
    If Nz(gAttach1, "") <> "" Then oItem.Attachments.Add (cAttachmentPath & gAttach1)

  End If
  SendEmail = True
  On Error Resume Next
  Set olApp = Nothing
  Set oItem = Nothing
  Exit Function
  MsgBox "Error " & Err.Number & ", " & Err.Description & " Occurred in SendEmail after " & ErrorLine
  Resume exit_SendEmail
End Function

also see
LVL 39

Accepted Solution

nutsch earned 1500 total points
ID: 39945758
One thing to do before you run the SplitColumnValuesIntoWorkbooksAndEmail macro on your example 2 file: turn your manager / report range into a table (select, Ctrl+T) and call that table tbSend. Then run the macro (on your example 2 file), and you'll just have to press send on the emails.

Option Explicit

Sub SplitColumnValuesIntoWorkbooksAndEmail()

Dim lLoop As Long, arrData As Variant
Dim shtData As Worksheet, wbkDest As Workbook, lgCol As Long, rgSel As Range
Dim cUnique As New Collection, sPath As String, sTemplatePath As String
Dim dDate As Date, dbDate As Double, loSend As ListObject, rgLoop As Range, wbkOrg As Workbook
Dim lkList As Variant

Const blTitles As Boolean = True                    'true if the data has titles, false otherwise
Const sColumn As String = "A"                       'Which column should the list be split on

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

sPath = "C:\temp\"

Set wbkOrg = ThisWorkbook
Set shtData = ActiveSheet
Set loSend = ActiveSheet.ListObjects("tbSend")
Set rgSel = loSend.ListColumns("Manager").DataBodyRange

'load the column into an array for faster processing
arrData = rgSel.Value

'load the array content in a collection, to keep individual values only
On Error Resume Next

For lLoop = LBound(arrData, 1) To UBound(arrData, 1)
    cUnique.Add arrData(lLoop, 1), CStr(arrData(lLoop, 1))

On Error GoTo 0
    'for each individual value, filter the list, copy the results to a new workbook, save and close the new workbook
For lLoop = 1 To cUnique.Count
    With loSend.Range
        .AutoFilter Field:=1, Criteria1:=cUnique(lLoop)
        For Each rgLoop In loSend.ListColumns("Report").DataBodyRange.SpecialCells(xlCellTypeVisible).Cells
            If wbkDest Is Nothing Then
                Set wbkDest = ActiveWorkbook
                wbkOrg.Sheets(rgLoop.Text).Copy after:=wbkDest.Sheets(wbkDest.Sheets.Count)
            End If
        Next rgLoop
        lkList = wbkDest.LinkSources(xlExcelLinks)
        wbkDest.SaveAs Filename:=sPath & cUnique(lLoop) & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
        wbkDest.Close True
        sendfile sPath & cUnique(lLoop) & ".xlsm", cUnique(lLoop)
        Set wbkDest = Nothing
    End With
Next lLoop

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

End Sub

Sub sendfile(sFilePath As String, sEmail As String)
'Initially copied from Ron de Bruin
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    OutMail.attachments.Add sFilePath
    With OutMail
        .To = sEmail
        .Subject = "Subject"
        .body = "Body "
        .Display 'or send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Open in new window


Author Closing Comment

ID: 39961373
Thanks for the help! Definitely got me in the right direction.

Featured Post

Important Lessons on Recovering from Petya

In their most recent webinar, Skyport Systems explores ways to isolate and protect critical databases to keep the core of your company safe from harm.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

If you troubleshoot Outlook for clients, you may want to know a bit more about the OST file before doing your next job. IMAP can cause a lot of drama if removed in the accounts without backing up.
Are you looking for the options available for exporting EDB files to PST? You may be confused as they are different in different Exchange versions. Here, I will discuss some options available.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This is my first video review of Microsoft Bookings, I will be doing a part two with a bit more information, but wanted to get this out to you folks.

650 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question