Consulting

Results 1 to 2 of 2

Thread: Email individual worksheets as attachment

  1. #1
    VBAX Regular
    Joined
    Nov 2018
    Posts
    17
    Location

    Email individual worksheets as attachment

    Hi all,

    I have an issue trying to find out how to send separate worksheets to individual email addresses, and wondered if someone could point me in the right direction.

    I have a project where i have managed to separate peoples individual data onto a worksheets just for them. I have created a separate list of all the names of all the worksheets which i would not like to email to each person.

    I have found loads of information about emailing attachments that are not part of the workbook, but cant seem to find anything for what i want to do. Or do i simply need to save the worksheet as separate file and send it?

    Thanks all

  2. #2
    You need to save the sheets as new workbooks e.g. as below. Here all the sheets in the workbook are added to a collection which is used to create the workbooks and their messages. If you have a list of sheets you can employ that to add the required sheet names to the collection. You will also need to associate the recipient addresses to the sheets, but this should get you started.

    Option Explicit
    
    Sub SendSheets()
    'Graham Mayor - https://www.gmayor.com - Last updated - 20 May 2020
    'Macro requires code functiom from
    'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    'to start Outlook correctly
    Dim olApp As Object
    Dim olMail As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Dim xlBook As Workbook
    Dim xlTemp As Workbook
    Dim xlSheet As Worksheet
    Dim sSheet As String
    Dim sPath As String
    Dim sName As String
    Dim FSO As Object
    Dim lngSheet As Long
    Dim strFile As String
    Dim oColl As Collection
    Const strSubject As String = "Please find workbook attached"
    Const strMessage As String = "This is the covering message text" & vbCr & vbCr & _
          "which will include the default signature associated with the account" & vbCr & vbCr & _
          "below this text."
    Const strFullName As String = "C:\Path\Filename.xlsx" 'The fullname of the workbook
    
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FileExists(strFullName) Then
            On Error Resume Next
            Set xlBook = Workbooks(strFile)
            If xlBook Is Nothing Then
                Set xlBook = Workbooks.Open(strFullName)
            End If
        Else
            Beep
            MsgBox "Workbook not found"
            GoTo lbl_Exit
        End If
        On Error GoTo 0
        
        'create a collection
        Set oColl = New Collection
        'add the sheet name to the collection
        For Each xlSheet In xlBook.Sheets
            oColl.Add xlSheet.Name
        Next
        'close the workbook
        xlBook.Close SaveChanges:=False
        
        'start Outlook using the code function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
        Set olApp = OutlookApp()
        'Loop through the sheets
        For lngSheet = 1 To oColl.Count
            sName = oColl(lngSheet)
            sPath = Environ("TEMP") & "\" & sName & ".xlsx"
            'create a temporary workbook based on the original workbook
            Set xlTemp = Workbooks.Add(Template:=strFullName)
            Application.DisplayAlerts = False
            'delete the unwanted sheets
            For Each xlSheet In xlTemp.Sheets
                If Not xlSheet.Name = sName Then xlSheet.Delete
            Next xlSheet
            'save the temporary workbook
            xlTemp.SaveAs sPath
            xlTemp.Close SaveChanges:=False
            Application.DisplayAlerts = True
            'create amessage to send the sheet
            Set olMail = olApp.CreateItem(0)
            With olMail
                'the recipient will need to be looked up and applied here
                .To = "someone@somewhere.com"
                .Subject = strSubject
                .BodyFormat = 2    'html
                Set olInsp = .GetInspector
                Set wdDoc = olInsp.WordEditor    'access the message body for editing
                Set oRng = wdDoc.Range
                oRng.Collapse 1
                oRng.Text = strMessage
                .Display    'required to edit message body
                .Attachments.Add sPath
                '.Send 'restore after testing
            End With
            On Error GoTo 0
            'delete the temporary file
            If FSO.FileExists(sPath) Then
                SetAttr sPath, vbNormal
                Kill sPath
            End If
        Next lngSheet
    lbl_Exit:
        Set FSO = Nothing
        Set olApp = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Set olMail = Nothing
        Set xlBook = Nothing
        Set xlTemp = Nothing
        Set xlSheet = Nothing
        Set oColl = Nothing
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •