VBA to eMail (Outlook) Worksheets Individually

[Small Paul]

Hi

I have a workbook with a set of data which needs to emailed to a variety of recipients on a daily basis.
I have a macro which searches for a 'unique' value on each row and sets up (and names) a new worksheet for each.

Each worksheet then needs to be emailed, using outlook, to the individual whose email address is in cell B2. I have found the following macro online but cannot get it to work.

Mail_Worksheets_TEST Macro'
    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
    End If


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


    Set OutApp = CreateObject("Outlook.Application")


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


            sh.Copy
            Set wb = ActiveWorkbook


            TempFileName = "Sheet " & sh.Name & " of " _
                         & ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


            Set OutMail = OutApp.CreateItem(0)


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


                On Error Resume Next
                With OutMail
                    .to = sh.Range("B2").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = "IGNORE - Just Testing"
                    .Body = "Cymru Rule"
                    .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

The macro runs through without an 'error' but no email is received.

Can anybody please help?

Many thanks
Small Paul.

 

[Norie]

Only really needed the bit that sends the emails.

Anyway, if the only problem is that you don't want to send the master sheet, and the that sheet is called 'IFA Trade Commission', try this..

Sub Mail_Worksheets_TEST()
'
' Mail_Worksheets_TEST Macro'
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
    End If

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

    Set OutApp = CreateObject("Outlook.Application")

    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "IFA Trade Commission" Then
            If sh.Range("L2").Value Like "?*@?*.?*" Then

                sh.Copy
                Set wb = ActiveWorkbook

                TempFileName = "Sheet " & sh.Name & " of " _
                               & ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

                Set OutMail = OutApp.CreateItem(0)

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

                    On Error Resume Next
                    With OutMail
                        .to = sh.Range("B2").Value
                        .CC = ""
                        .BCC = ""
                        .Subject = "OFFS!"
                        .Body = "Cymru Will Thrash England in the 6Nations!!"
                        .Send   'or use .Display
                    End With
                    On Error GoTo 0

                    .Close Savechanges:=False
                End With

                Set OutMail = Nothing

                Kill TempFilePath & TempFileName & FileExtStr

            End If
        End If
    Next sh

    Set OutApp = Nothing

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

End Sub