send each sheet to each persons via outlook

[nagasree]

I have a master sheet and a code to split it into separate sheet based on reviewer names, now i need to send all the splitted sheet to each of the reviewers based on sheet names, example: sheet named raj must be sent to raj@gmail.com, sheet named ravi must be sent to ravi@gmail.com I managed to find a code to send a single sheet via mail, i need help to send all the sheets to respective persons via outlook.
Attaching the code to send a single sheet.
Sub EmailWithOutlook()
Dim oApp As Object
Dim oMail As Object
Dim WB As Workbook
Dim FileName As String
Dim wSht As Worksheet
Dim ShtName As String
Dim CurrDate As String
CurrDate = format(Date, "MM-DD-YY")

Application.ScreenUpdating = False
' Make a copy of the active worksheet
' and save it to a temporary file
Sheets("raj").Activate
ActiveSheet.Copy
Set WB = ActiveWorkbook

FileName = WB.Worksheets(1).Name & " " & CurrDate
On Error Resume Next
Kill "C:\Users\Desktop\workfiles\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="C:\Users\Desktop\workfiles\" & FileName

'Create and show the Outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
'Uncomment the line below to hard code a recipient
.To = "raj@gmail.com"
'Uncomment the line below to hard code a subject
.Subject = "Subject Line"
'Uncomment the lines below to hard code a body
.body = "Hi Raj" & vbCrLf & vbCrLf & _
"Please find the attached file for work"
.Attachments.Add WB.FullName
.Display
End With

'Delete the temporary file
'WB.ChangeFileAccess Mode:=xlReadOnly
'Kill WB.FullName
'WB.Close SaveChanges:=False

'Restore screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub

 

[dmt32]

Hi,
not fully tested but give following a try & see if does what you want

Sub EmailWithAttachment()
    
    Dim emailApplication    As Object, emailItem As Object
    Dim ws                  As Worksheet, wsMaster As Worksheet
    Dim wb                  As Workbook
    Dim RecipientName       As String, strFilename As String
    
    Const FolderPath As String = "C:\Users\Desktop\workfiles\"
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
    
    On Error GoTo myerror
    Set wsMaster = ThisWorkbook.Worksheets("Master")
    Set emailApplication = CreateObject("Outlook.Application")
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> wsMaster.Name Then
            
            ws.Copy
            Set wb = ActiveWorkbook
            
            RecipientName = wb.Worksheets(1).Name
            strFilename = RecipientName & ".xlsx"
            
            wb.SaveAs Filename:=FolderPath & strFilename, FileFormat:=51
            
            emailaddress = RecipientName & "@gmail.com"
            
            Set emailItem = emailApplication.CreateItem(0)
            
            With emailItem
                .To = emailaddress
                .Subject = "Subject Line"
                .body = "Hi " & RecipientName & vbCrLf & vbCrLf & _
                        "Please find the attached file For work"
                .Attachments.Add wb.FullName
                .Display
            End With
            
            'clean up
            wb.ChangeFileAccess Mode:=xlReadOnly
            Kill wb.FullName
            
            wb.Close False
            
            Set emailItem = Nothing
            Set wb = Nothing
        End If
    Next ws
    
    MsgBox "All Complete", 64, "Complete"
    
myerror:
    If Not wb Is Nothing Then wb.Close False
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Change the name of the Master sheet shown in BOLD as required

Dave

 

[nagasree]

Hi,
not fully tested but give following a try & see if does what you want

Sub EmailWithAttachment()
   
    Dim emailApplication    As Object, emailItem As Object
    Dim ws                  As Worksheet, wsMaster As Worksheet
    Dim wb                  As Workbook
    Dim RecipientName       As String, strFilename As String
   
    Const FolderPath As String = "C:\Users\Desktop\workfiles\"
   
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
   
    On Error GoTo myerror
    Set wsMaster = ThisWorkbook.Worksheets("Master")
    Set emailApplication = CreateObject("Outlook.Application")
   
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> wsMaster.Name Then
           
            ws.Copy
            Set wb = ActiveWorkbook
           
            RecipientName = wb.Worksheets(1).Name
            strFilename = RecipientName & ".xlsx"
           
            wb.SaveAs Filename:=FolderPath & strFilename, FileFormat:=51
           
            emailaddress = RecipientName & "@gmail.com"
           
            Set emailItem = emailApplication.CreateItem(0)
           
            With emailItem
                .To = emailaddress
                .Subject = "Subject Line"
                .body = "Hi " & RecipientName & vbCrLf & vbCrLf & _
                        "Please find the attached file For work"
                .Attachments.Add wb.FullName
                .Display
            End With
           
            'clean up
            wb.ChangeFileAccess Mode:=xlReadOnly
            Kill wb.FullName
           
            wb.Close False
           
            Set emailItem = Nothing
            Set wb = Nothing
        End If
    Next ws
   
    MsgBox "All Complete", 64, "Complete"
   
myerror:
    If Not wb Is Nothing Then wb.Close False
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Change the name of the Master sheet shown in BOLD as required

Dave

Hello the macro is running and it shows subscription out of range

 

[dmt32]

Hello the macro is running and it shows subscription out of range

Did you rename the master sheet where shown in RED to that of your actual master sheet name?

Dave

 

[nagasree]

Did you rename the master sheet where shown in RED to that of your actual master sheet name?

Dave

yes i did

 

[nagasree]

yes i did

How to send each sheet to different email addresses from Excel?

If you have a workbook with several worksheets, and there is an email address in cell A1 of each sheet. Now, you want to send each sheet from the workbook as an attachment to corresponding recipient in cell A1 individually. How could you solve this task in Excel? This article, I will introduce a VBA

www.extendoffice.com

found this, but this code is also not working, can u please modify it according to my need

 

[dmt32]

can you comment out this line

On Error GoTo myerror

run the code & tell me which line is showing the error

Dave

 

[nagasree]

can you comment out this line

On Error GoTo myerror

run the code & tell me which line is showing the error

Dave

Its not taking to line, no yellow highlighted, directly says subscription out of range

 

[dmt32]

Its not taking to line, no yellow highlighted, directly says subscription out of range

can you place copy of your workbook with dummy data in a filesharing site like dropbox & provide a link to it?

Dave

 

[dmt32]

How to send each sheet to different email addresses from Excel?

If you have a workbook with several worksheets, and there is an email address in cell A1 of each sheet. Now, you want to send each sheet from the workbook as an attachment to corresponding recipient in cell A1 individually. How could you solve this task in Excel? This article, I will introduce a VBA

www.extendoffice.com

found this, but this code is also not working, can u please modify it according to my need

if you want to use another's code suggest that you liaise with the author.

Dave