Macro to Email Excel Worksheets Based on Cell References

Posted on 2014-03-20
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 500 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

NFR key for Veeam Backup for Microsoft Office 365

Veeam is happy to provide a free NFR license (for 1 year, up to 10 users). This license allows for the non‑production use of Veeam Backup for Microsoft Office 365 in your home lab without any feature limitations.

Question has a verified solution.

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

You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

749 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