Macro to Email Excel Worksheets Based on Cell References

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.
Who is Participating?
nutschConnect With a Mentor Commented:
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

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.
thomas-sherrouseAuthor Commented:
Yes - That is correct.
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
thomas-sherrouseAuthor Commented:
Thanks for the help! Definitely got me in the right direction.
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.