VBA Email Automation

[no_chill]

Hello Guys Im new here and seeking some help in VBA

okay so I have a report that I usually do, and I already made a macro that splits the report to pages depending on the country name.

I want a vba that reads the sheet name, and send the sheet only to the assigned email for this sheet, the sheet name will be country name.

for example if the sheet name is Peru, it sends to handling person in Peru, if its in Egypt, it sends to specific handling person in Egypt, and so on

Any help please ?

 

[Logit]

.
The sheets you want emailed .... in cell A1 of those sheets, enter the email address where the sheet is to be emailed.

Paste this macro into a Regular module :

Option Explicit

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

    TempFilePath = Environ$("temp") & "\"

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsm": FileFormatNum = 52
        FileExtStr = ".xlsx": FileFormatNum = 51
        
    End If

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

    Set OutApp = CreateObject("Outlook.Application")

    For Each sh In ThisWorkbook.Worksheets
        If sh.Range("A1").Value Like "?*@?*.?*" Then

            sh.Copy
            Set wb = ActiveWorkbook

            TempFileName = sh.Name

            Set OutMail = OutApp.CreateItem(0)

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

                On Error Resume Next
                With OutMail
                    .to = sh.Range("A1").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = "This is the Subject line"
                    .Body = "Hi there"
                    .Attachments.Add wb.FullName
                    .Display
                    '.Send   'or use .Display
                End With
                On Error GoTo 0

                .Close savechanges:=False
            End With
            
            Set OutMail = Nothing

            Kill TempFilePath & TempFileName & FileExtStr

        End If
    Next sh

    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Create a CommandButton on any sheet and connect it to the macro named : Mail_Every_Worksheet

 

[no_chill]

Hello,

Thanks a lot but how can assign email automatically for each page ? so that the full thing will be automated ?

 

[Logit]

Using your example ... a sheet is named Peru. Where is the email address located for the sheet Peru ?
Are all sheets designed in the same manner so the email address shows up in the same location for that sheet ?

Describe in detail how to find the email address for each sheet.

Better yet, post a copy of your workbook (no confidential information please) to a download site and provide the download link here.
That will speed things up and eliminate all of the questions.

 

[no_chill]

Taking the Peru example, I want to assign the email "Peru123@gmail.com" to the page that will be named peru, without putting this email in cell A1
the email for peru is always fixed so automatically the vba will send the sheet to the assigned email

can it work ?

 

[Logit]

Option Explicit

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

    TempFilePath = Environ$("temp") & "\"

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsm": FileFormatNum = 52
        FileExtStr = ".xlsx": FileFormatNum = 51
        
    End If

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

    Set OutApp = CreateObject("Outlook.Application")

    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Sheet1" Then

            sh.Copy
            Set wb = ActiveWorkbook

            TempFileName = sh.Name

            Set OutMail = OutApp.CreateItem(0)

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

                On Error Resume Next
                With OutMail
                    .to = sh.Name & "@gmail.com"
                    .CC = ""
                    .BCC = ""
                    .Subject = "This is the Subject line"
                    .Body = "Hi there"
                    .Attachments.Add wb.FullName
                    .Display
                    '.Send   'or use .Display
                End With
                On Error GoTo 0

                .Close savechanges:=False
            End With
            
            Set OutMail = Nothing

            Kill TempFilePath & TempFileName & FileExtStr

        End If
    Next sh

    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[no_chill]

Thanks a lot sir

But cant I include an if function ? that for example if sheet name is Peru, to be sent to peru123@gmail.com and 321peru@gmail.com (Just examples)

 

[Logit]

The macro, as it is presently written, will handle those differences.