[Okta Webinar] Learn how to a build a cloud-first strategyRegister 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
  • 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

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

This article lists the top 5 trialware OST to PST Converter Tools. These tools save a lot of time for users when they want to convert OST to PST after their Exchange server is no longer available or other critical issues with Exchange server or impo…
This article describes how to import Lotus Notes Contacts into Outlook 2016, 2013, 2010 and 2007 etc. with a few manual steps. You can easily export and migrate Lotus Notes contacts into Microsoft Outlook without having to use any third party tools.
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…
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…
Suggested Courses

873 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