E-mail Sheets & attaching word doc

  • I have a file, that I send each week to several members of the management. Each person gets a different sheet of that file (excel), along with a covering memo (word document). If I included the e-mail addresses of the persons I want to receive each sheet on that sheet, is there a macro that can autosend the e-mails for me and attaching the word document on it as well??
    PS. I use Microsoft Outlook:puzzled:

  • Hi Chris,

    Below You will find a working example which You can adapt for Your solution.

    1. Add a new sheet to the workbook
    2. Create a rangename - rnRecipients
    3. Create a rangename - rnWorksheets
    4. Fill in the e-mailaddress in rnRecipients
    5. Fill in the worksheet-names in rnWorksheets
    6. Switch over to the VB-editor and add a standard-module to the VB-project.
    7. Paste following code into the module and make necessary changes.

    Option Explicit

    Sub Send_XLSheets_Word_Outlook()
    'You need to set a reference to the MS Outlook x.x library via
    'Tools | Reference in the VB-editor.
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim rnRecipients As Range, rnWorkSheets As Range, rnCell As Range
    Dim stName As String
    Dim i As Long
    Dim olApp As Outlook.Application
    Dim olNewMail As Outlook.MailItem

    Set olApp = New Outlook.Application
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets("Sheet1")

    With wsSheet
    'Here we have created a list of recipients.
    Set rnRecipients = .Range("rnRecipients")
    'Here we have created a list of singel worksheets in the active workbook.
    Set rnWorkSheets = .Range("rnWorksheets")
    End With

    Application.ScreenUpdating = False

    For i = 1 To rnRecipients.Count
    Set olNewMail = CreateItem(olMailItem)
    With olNewMail
    'Here we add the recipients.
    .Recipients.Add rnRecipients(i, 1).Value
    .Subject = "Subject: Reports"
    .Body = "As per agreed"
    With .Attachments
    'Here we add the word-memo.
    .Add ThisWorkbook.Path & "\" & "Report.doc"
    .Item(1).DisplayName = "Summery - Report"
    'Here we copy, create a new workbook and add a worksheets.
    stName = rnWorkSheets(i, 1).Value
    With ActiveWorkbook
    .SaveAs Filename:=stName & ".xls"
    End With
    .Add ThisWorkbook.Path & "\" & stName & ".xls"
    .Item(2).DisplayName = "Details - Report"
    End With
    End With
    Next i

    Set olNewMail = Nothing
    Set olApp = Nothing

    'Delete all the created workbooks
    For i = 1 To rnRecipients.Count
    Kill ThisWorkbook.Path & "\" & rnWorkSheets(i, 1).Value & ".xls"
    Next i

    Application.ScreenUpdating = True
    End Sub