Sending separate worksheets to multiple recipients from a sheet listing email addresses and sheet names.

[nthpl888]

Hi All,

I'm fairly new to VBA and trying to combine 2 VBA codes to create the perfect solution, but i'm not having much luck!

I need to run a macro to email sheets from a large workbook to multiple recipients using a list in "Contacts" that has the sheet names in column b and the email addresses in column c. I'm currently trying to merge elements from the two codes below.

The first code emails the sheets fine, and the second code picks up the array like we need, how do i merge the two functions?

Any help greatly appreciated, thank you

Sub Mail_Sheets_Array()'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim TheActiveWindow As Window
    Dim TempWindow As Window


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    Set Sourcewb = ActiveWorkbook


    'Copy the sheets to a new workbook
    'We add a temporary Window to avoid the Copy problem
    'if there is a List or Table in one of the sheets and
    'if the sheets are grouped
    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("Sheet1", "Sheet3")).Copy
    End With

Public Sub MAILRUN() Dim shname As Range, EmailAddr As String
   With ThisWorkbook.Sheets("CONTACTS"), this is the sheet where names and Email addresses are stored
      For Each shname In .Columns("B:B").SpecialCells(xlCellTypeConstants, 3)
            EmailAddr = shname.Offset(0, -1).Value
            With Sheets(shname.Value)
               .Activate
                ActiveSheet.Copy
                Filename = shname & ".xls"
                ActiveWorkbook.SaveAs "C:\data\" & Filename, FileFormat:=52
        Set wb = ActiveWorkbook
        Set Mail_Object = CreateObject("Outlook.Application")
            With Mail_Object.CreateItem(o)
                .Subject = "SUBJECT LINE HERE"
                .To = EmailAddr
                .Body = "YOUR TEXT GOES HERE" & Chr(13) & Chr(13) & "Regards," & Chr(13) & Chr(13) & "YOURNAME" & Chr(13) & Chr(13) & "YOUR OFFICE NAME"
                .Attachments.Add "C:\data\" & Filename
                .display '.Send change to Send if you don't need to check E-Mail before sending
            End With
            End With
    wb.ChangeFileAccess Mode:=xlReadOnly
    wb.Close SaveChanges:=False
      Next shname
   End With
End Sub