Emailing sheets different emails.

[Dilshan Anandan]

Hi All,

I am trying to do an automation of an excel emailing process. I have a workbook which as around 68 sheets in it. I have to send the sheets as attachments to multiple email IDs. The Email ID are in the A1 cell in each sheet. There are some sheets which needs to be sent to one email ID, In this case i am finding it difficult to send it as a single Email with multiple attachments. I have written a code, Where it sends all the sheets in separate Email. But i want it to check if a particular email ID has more than one sheet, if so send all of them in one email with multiple attachment. for example if 3 sheets has the same Email ID, I need 3 attachment in 1 email. but my code sends 3 mails with each 1 attachment.

please see the below code which i have written.

Sub Mail()
  
  Dim Subject As String
  Subject = InputBox("What should be the subject in the Email?")
  Dim Due As String
  Due = InputBox("What is the due date for the reply?")
  Dim CCMAIL As String
  CCMAIL = InputBox("to whom do you want to carbon copy the mail?")
  Dim BCCMAIL As String
  BCCMAIL = InputBox("to whom do you want to blind copy the mail?")
    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

        FileExtStr = ".xls": FileFormatNum = -4143
    Else

        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("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 = CCMAIL
                    .BCC = BCCMAIL
                    .Subject = Subject
                    .Body = "132"


                    
                    .Attachments.Add wb.FullName
                    .Send
                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

And the email address are fixed based on the sheet name.

If someone knows what adjustment has to be done or where i have gone wrong, please help out.
Thanks in advance for spending your time ion reading this.