none
VBA in Excel - Emailing Multiple Worksheets Based on Distribution List RRS feed

  • Question

  • Hello Developers,

    I'm needing help with setting up a macro in VBA for Excel 2013 or later.  Looking to automatically send several worksheets based on a specific distribution list.  Example, Sheet1 goes to 3 people, Sheet2 goes to 4 people, and so on.

    I'm a bit of an amateur and can't create something from scratch, but have done some research on the forums.  The best example I found is an old topic from 2003, but when I ran it, the code did not work with Excel 2013.  Listed below is the hyperlink, but the specific example in that topic is called "Send Worksheets to One or More People by E-mail".  I need to have a master distribution list similar to the one listed, which this one is labeled "mail".  Any help is appreciated!

    https://msdn.microsoft.com/en-us/library/aa203718(v=office.11).aspx#odc_mailanarrayofworksheets

    Saturday, October 15, 2016 10:17 PM

Answers

  • Hi Bobostick,

    Which error did you get? If you got “Next without For”, I suggest you try below code:

    Sub Mail_sheets()
        Dim MyArr As Variant
        Dim last As Long
        Dim shname As Long
        Dim a As Integer
        Dim Arr() As String
        Dim N As Integer
        Dim strdate As String
        For a = 1 To 253 Step 3
            If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
                Exit Sub
            End If
            Application.ScreenUpdating = False
            last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, _
                a).End(xlUp).Row
            N = 0
            For shname = 1 To last
                N = N + 1
                ReDim Preserve Arr(1 To N)
                Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
            Next shname
            ThisWorkbook.Sheets(Arr).Copy
            strdate = Format(Date, "dd-mm-yy") & " " & _
                Format(Time, "h-mm-ss")
            ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
                & " " & strdate & ".xls"
            With ThisWorkbook.Sheets("mail")
                MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, _
                    a + 1).End(xlUp))
            End With
            ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
            ActiveWorkbook.ChangeFileAccess xlReadOnly
            Kill ActiveWorkbook.FullName
            ActiveWorkbook.Close False
            Application.ScreenUpdating = True
        Next a
    End Sub

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Monday, October 17, 2016 6:35 AM
  • Thank you!!  That code worked like a charm.  Only change I made was the file extension from xls to xlsx

    Really appreciate the help and quick response.

    ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
                & " " & strdate & ".xlsx"

    • Marked as answer by Bobostick Sunday, October 23, 2016 9:11 PM
    Wednesday, October 19, 2016 2:39 AM

All replies

  • Hi Bobostick,

    Which error did you get? If you got “Next without For”, I suggest you try below code:

    Sub Mail_sheets()
        Dim MyArr As Variant
        Dim last As Long
        Dim shname As Long
        Dim a As Integer
        Dim Arr() As String
        Dim N As Integer
        Dim strdate As String
        For a = 1 To 253 Step 3
            If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
                Exit Sub
            End If
            Application.ScreenUpdating = False
            last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, _
                a).End(xlUp).Row
            N = 0
            For shname = 1 To last
                N = N + 1
                ReDim Preserve Arr(1 To N)
                Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
            Next shname
            ThisWorkbook.Sheets(Arr).Copy
            strdate = Format(Date, "dd-mm-yy") & " " & _
                Format(Time, "h-mm-ss")
            ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
                & " " & strdate & ".xls"
            With ThisWorkbook.Sheets("mail")
                MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, _
                    a + 1).End(xlUp))
            End With
            ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
            ActiveWorkbook.ChangeFileAccess xlReadOnly
            Kill ActiveWorkbook.FullName
            ActiveWorkbook.Close False
            Application.ScreenUpdating = True
        Next a
    End Sub

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Monday, October 17, 2016 6:35 AM
  • Thank you!!  That code worked like a charm.  Only change I made was the file extension from xls to xlsx

    Really appreciate the help and quick response.

    ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
                & " " & strdate & ".xlsx"

    • Marked as answer by Bobostick Sunday, October 23, 2016 9:11 PM
    Wednesday, October 19, 2016 2:39 AM
  • Hi Bobostick,

    I am glad it works for you.

    I would suggest you mark the reply as answer, and then other who run into the same issue would find the solution easily.

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Wednesday, October 19, 2016 6:34 AM