Results 1 to 1 of 1

Thread: 1 Email, Multiple Recipients, No Duplicates

  1. #1

    1 Email, Multiple Recipients, No Duplicates

    So, I'm trying to send an email to anyone whose status in Column K is Open or Pending. The correlated email is listed in Column J (I cannot switch the columns). These emails are listed multiple times so I don't want to duplicate.

    Sub SendEmail()
        Dim FileExtStr As String
        Dim FileFormatNum As Long
        Dim Sourcewb As Workbook
        Dim Destwb As Workbook
        Dim TempFilePath As String
        Dim TempFileName As String
        Dim OutApp As Object
        Dim OutMail As Object
        Dim sh As Worksheet
        Dim TheActiveWindow As Window
        Dim TempWindow As Window
    With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
    Set Sourcewb = ActiveWorkbook
    'Copy the sheets to a new workbook
        'We add a temporary Window to avoid the Copy problem
        'if there is a List or Table in one of the sheets and
        'if the sheets are grouped
        With Sourcewb
            Set TheActiveWindow = ActiveWindow
            Set TempWindow = .NewWindow
            .Sheets(Array("New CC Form_LH", "New CC Form_LS")).Copy
        End With
    'Close temporary Window
    Set Destwb = ActiveWorkbook
    'Determine the Excel version and file extension/format
        With Destwb
            If Val(Application.Version) < 12 Then
                'You use Excel 97-2003
                FileExtStr = ".xls": FileFormatNum = -4143
                'You use Excel 2007-2016
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End With
    'Save the new workbook/Mail it/Delete it
        TempFilePath = Environ$("temp") & ""
        TempFileName = "New CC Forms"
    Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    With Destwb
            .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = ""
            .Body = ""
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
        End With
        On Error GoTo 0
        .Close savechanges:=False
    'Delete the file you have send
        Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
        Set OutApp = Nothing
    With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
        End With
    End Sub
    It also attaches two other sheets as an attachment. It work fine in sending the email, but its listing recipients on the file that I am struggling with. Let me know if there is any other information I can provide.
    Last edited by Aussiebear; 08-23-2018 at 06:27 PM. Reason: Enclosed code with code tags

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts