Send multiple excel worksheets using a control sheet

[JSF_99]

Hi,

I would like to send multiple worksheets based on a control sheet.

I have put together an example (attached)..... ideally would like the vba to loop through the various Rows till it reaches the end of the table.

Thanks

JSF

 

[John_w]

Try this macro:

Public Sub Email_Worksheets()

    Dim OutApp As Object, OutEmail As Object
    Dim r As Long
    Dim tempWorkbookFullName As String
    Dim emailSubject As String, toEmailAddresses As String

    Set OutApp = CreateObject("Outlook.Application")
    
    With Worksheets("Control Sheet")
    
        For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
        
            emailSubject = .Cells(r, "A").Value
            toEmailAddresses = .Cells(r, "B").Value
            
            tempWorkbookFullName = Environ("temp") & "\" & .Cells(r, "A").Value & ".xlsx"
            If Dir(tempWorkbookFullName) <> vbNullString Then Kill tempWorkbookFullName

            Worksheets(Split(.Cells(r, "C").Value, ";")).Copy
            ActiveWorkbook.SaveAs Filename:=tempWorkbookFullName
            ActiveWorkbook.Close False
            
            Set OutEmail = OutApp.createItem(0)
            
            With OutEmail
                .To = toEmailAddresses
                .Subject = emailSubject
                .Body = "This is the email body text."
                .Attachments.Add tempWorkbookFullName
                .Display  'or .Send
            End With
            
        Next
        
    End With
   
    Kill tempWorkbookFullName
    
    MsgBox "Done"
    
End Sub

 

[JSF_99]

Try this macro:

Public Sub Email_Worksheets()

    Dim OutApp As Object, OutEmail As Object
    Dim r As Long
    Dim tempWorkbookFullName As String
    Dim emailSubject As String, toEmailAddresses As String

    Set OutApp = CreateObject("Outlook.Application")
   
    With Worksheets("Control Sheet")
   
        For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
       
            emailSubject = .Cells(r, "A").Value
            toEmailAddresses = .Cells(r, "B").Value
           
            tempWorkbookFullName = Environ("temp") & "\" & .Cells(r, "A").Value & ".xlsx"
            If Dir(tempWorkbookFullName) <> vbNullString Then Kill tempWorkbookFullName

            Worksheets(Split(.Cells(r, "C").Value, ";")).Copy
            ActiveWorkbook.SaveAs Filename:=tempWorkbookFullName
            ActiveWorkbook.Close False
           
            Set OutEmail = OutApp.createItem(0)
           
            With OutEmail
                .To = toEmailAddresses
                .Subject = emailSubject
                .Body = "This is the email body text."
                .Attachments.Add tempWorkbookFullName
                .Display  'or .Send
            End With
           
        Next
       
    End With
  
    Kill tempWorkbookFullName
   
    MsgBox "Done"
   
End Sub

Hi John,
Thank you very much for your reply.
Works exactly as i had imagined it.
Thanks
JSF