Solved

Macro to Email Excel Worksheets Based on Cell References

Posted on 2014-03-20
5
592 Views
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.
ReportDistrubtionExample1.xlsx
ReportDistrubtionExample2.xlsx
0
Comment
Question by:thomas-sherrouse
  • 2
  • 2
5 Comments
 
LVL 7

Expert Comment

by:COACHMAN99
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.
0
 

Author Comment

by:thomas-sherrouse
ID: 39943397
Yes - That is correct.
0
 
LVL 7

Expert Comment

by:COACHMAN99
ID: 39943424
coding the whole app will me too much time unfortunately, but the key functions are
workbooks.add
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)
    oItem.Display

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

also see
http://www.techonthenet.com/excel/macros/email_sheet2007.php
0
 
LVL 39

Accepted Solution

by:
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))
Next

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
        
        .AutoFilter Field:=1, Criteria1:=cUnique(lLoop)
               
        For Each rgLoop In loSend.ListColumns("Report").DataBodyRange.SpecialCells(xlCellTypeVisible).Cells
            If wbkDest Is Nothing Then
                wbkOrg.Sheets(rgLoop.Text).Copy
                Set wbkDest = ActiveWorkbook
            Else
                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
        
        .AutoFilter
        
    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

0
 

Author Closing Comment

by:thomas-sherrouse
ID: 39961373
Thanks for the help! Definitely got me in the right direction.
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

Suggested Solutions

Resolve Outlook connectivity issues after moving mailbox to new Exchange 2016 server
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

706 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now