Sending email direct from Excel - code amendment

[marcidee]

I am sending emails directly from Excel using the below code - I would like to CC (or BCC) to an address added to sheet Column C (the same email address can be copied to all rows)

Please someone help to amend the code to add a CC for the address in Column C (Sheet2)

The worksheet has two sheets,

Sheet1

Name	P/E Date	Shift	Company	Location	Units	Pay Rate	Total Pay
Abraham	Tue 14 Jan 2020	SW - Day	Thames Reach	Deptford Thames Reach	11.50	£ 9.00	£ 103.50
Abraham	Sat 18 Jan 2020	SW - Day	Thames Reach	Deptford Thames Reach	7.00	£ 9.00	£ 63.00	£ 166.50
Name	P/E Date	Shift	Company	Location	Units	Pay Rate	Total Pay
Augustin	Sat 18 Jan 2020	SW - Day	St Mungos	Floating Hub Staging Post	9.50	£ 8.21	£ 78.00
Augustin	Sat 18 Jan 2020	SW - Day	St Mungos	SWEP - RSP 14 MARKET LANE	11.00	£ 8.21	£ 90.31	£ 168.31
Name	P/E Date	Shift	Company	Location	Units	Pay Rate	Total Pay
Bridget	Mon 13 Jan 2020	SW - Day	St Mungos	Engaged and Planning	7.50	£ 8.21	£ 61.58
Bridget	Tue 14 Jan 2020	SW - Day	St Mungos	Engaged and Planning	7.50	£ 8.21	£ 61.58	£ 123.15

Sheet2

Column C to be added at CC

Abraham	abraham@yahoo.co.uk	marc@dr.com
augustin	augustin@hotmail.com	marc@dr.com
Bridget	Bridget@yahoo.com	marc@dr.com

Sub Send_Row_Or_Rows_Attachment_1()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

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

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A1:I" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Sheet2").Range("A1:B" & _
Worksheets("Sheet2").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress <> "" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value

'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set NewWB = Workbooks.Add(xlWBATWorksheet)

rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

'Create a file name
dPrevious_Sunday = DateAdd("d", -Weekday(Now) + 1, Now)
TempFilePath = Environ$("temp") & "\"
TempFileName = "Pay Breakdown For Week Ending " & Format(dPrevious_Sunday, "DD MMM YYYY")

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

'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)

With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = mailAddress
.Subject = "Pay Breakdown For Week Ending " & Format(dPrevious_Sunday, "DD MMM YYYY")
.Attachments.Add NewWB.FullName
.Body = "Please find enclosed a pay breakdown."

.Body = "The payslip will have been sent separately. If you have any issues please don’t hesitate to let us know at the earliest opportunity."

.Send 'Or use Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If

'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

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

 

[DanteAmor]

I put the code with some small adjustments.

Sub Send_Row_Or_Rows_Attachment_1()
  Dim OutApp As Object, OutMail As Object
  Dim Ash As Worksheet, Cws As Worksheet, NewWB As Workbook
  Dim Rnum As Long, FileFormatNum As Long, FieldNum As Integer
  Dim rng As Range, FilterRange As Range
  Dim mailAddress As String, TempFilePath As String, TempFileName As String
  Dim FileExtStr As String, dPrevious_Sunday As Variant
  Dim f As Range
  
  On Error GoTo cleanup
  Set OutApp = CreateObject("Outlook.Application")
  
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
  End With
  
  'Set filter sheet, you can also use Sheets("MySheet")
  Set Ash = ActiveSheet
  
  'Set filter range and filter column (column with names)
  Set FilterRange = Ash.Range("A1:I" & Ash.Range("A" & Rows.Count).End(xlUp).Row)
  FieldNum = 1 'Filter column = A because the filter range start in column A
  
  'Add a worksheet for the unique list and copy the unique list in A1
  Set Cws = Worksheets.Add
  FilterRange.Columns(FieldNum).AdvancedFilter _
    Action:=xlFilterCopy, _
    CopyToRange:=Cws.Range("A1"), _
    CriteriaRange:="", Unique:=True
  
  'If there are unique values start the loop
  For Rnum = 2 To Cws.Range("A" & Rows.Count).End(xlUp).Row
    
    'Look for the mail address in the MailInfo worksheet
    Set f = Sheets("Sheet2").Range("A:A").Find(Cws.Cells(Rnum, 1).Value, , xlValues, xlWhole)
    
    If Not f Is Nothing Then
    
      'Filter the FilterRange on the FieldNum column
      FilterRange.AutoFilter Field:=FieldNum, Criteria1:=Cws.Cells(Rnum, 1).Value
      
      'Copy the visible data in a new workbook
      With Ash.AutoFilter.Range
        On Error Resume Next
        Set rng = .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
      End With
      
      Set NewWB = Workbooks.Add(xlWBATWorksheet)
      
      rng.Copy
      With NewWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
      End With
      
      'Create a file name
      dPrevious_Sunday = DateAdd("d", -Weekday(Now) + 1, Now)
      TempFilePath = Environ$("temp") & "\"
      TempFileName = "Pay Breakdown For Week Ending " & Format(dPrevious_Sunday, "DD MMM YYYY")
      
      If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
      Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
      End If
      
      'Save, Mail, Close and Delete the file
      Set OutMail = OutApp.CreateItem(0)
      
      With NewWB
        .SaveAs TempFilePath & TempFileName _
        & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
          .To = f.Offset(, 1).Value
          .Cc = f.Offset(, 2).Value
          .Subject = "Pay Breakdown For Week Ending " & Format(dPrevious_Sunday, "DD MMM YYYY")
          .Attachments.Add NewWB.FullName
          .Body = "Please find enclosed a pay breakdown."
          .Body = "The payslip will have been sent separately. If you have any issues please don’t hesitate to let us know at the earliest opportunity."
          .Display
          '.Send 'Or use Send
        End With
        On Error GoTo 0
        .Close savechanges:=False
      End With
      
      Set OutMail = Nothing
      Kill TempFilePath & TempFileName & FileExtStr
    End If
    'Close AutoFilter
    Ash.AutoFilterMode = False
  Next Rnum
  
cleanup:
  Set OutApp = Nothing
  Application.DisplayAlerts = False
  Cws.Delete
  Application.DisplayAlerts = True
  With Application
    .EnableEvents = True
    .ScreenUpdating = True
  End With
End Sub

 

[DanteAmor]

Hi, I made more adjustments to the code with another approach to make the code shorter.

Sub Send_Row_Or_Rows_Attachment_1()
  Dim OutApp As Object, OutMail As Object, Ash As Worksheet, NewWB As Workbook
  Dim FileFormatNum As Long, TempFilePath As String, TempFileName As String
  Dim FilterRange As Range, f As Range, FileExtStr As String, dPrevious_Sunday As Variant
  Dim dic As Object, ky As Variant, i As Long, a As Variant
  
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  
  Set OutApp = CreateObject("Outlook.Application")
  Set Ash = ActiveSheet
  Set dic = CreateObject("Scripting.Dictionary")
  Set FilterRange = Ash.Range("A1:I" & Ash.Range("A" & Rows.Count).End(xlUp).Row)
  
  a = FilterRange.Columns(1).Value
  For i = 2 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      Set f = Sheets("Sheet2").Range("A:A").Find(a(i, 1), , xlValues, xlWhole)
      If Not f Is Nothing Then dic(a(i, 1)) = f.Offset(, 1).Value & "|" & f.Offset(, 2).Value
    End If
  Next
  
  'If there are unique values start the loop
  For Each ky In dic.keys
    'Filter the FilterRange on the FieldNum column
    FilterRange.AutoFilter Field:=1, Criteria1:=ky
    
    'Copy the visible data in a new workbook
    Set NewWB = Workbooks.Add(xlWBATWorksheet)
    Ash.AutoFilter.Range.EntireRow.Copy
    With NewWB.Sheets(1)
      .Cells(1).PasteSpecial Paste:=8
      .Cells(1).PasteSpecial Paste:=xlPasteValues
      .Cells(1).PasteSpecial Paste:=xlPasteFormats
      .Cells(1).Select
    End With
    
    'Create a file name
    dPrevious_Sunday = DateAdd("d", -Weekday(Now) + 1, Now)
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Pay Breakdown For Week Ending " & Format(dPrevious_Sunday, "DD MMM YYYY")
    
    If Val(Application.Version) < 12 Then
      FileExtStr = ".xls": FileFormatNum = -4143  'You use Excel 97-2003
    Else
      FileExtStr = ".xlsx": FileFormatNum = 51    'You use Excel 2007-2016
    End If
    
    'Save, Mail, Close and Delete the file
    Set OutMail = OutApp.CreateItem(0)
    NewWB.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    
    On Error Resume Next
    With OutMail
      .To = Split(dic(ky), "|")(0)
      .Cc = Split(dic(ky), "|")(1)
      .Subject = TempFileName
      .Attachments.Add NewWB.FullName
      .Body = "Please find enclosed a pay breakdown."
      .Body = "The payslip will have been sent separately. If you have any issues please don’t hesitate to let us know at the earliest opportunity."
      '.Display
      .Send 'Or use Send
    End With
    On Error GoTo 0
    
    NewWB.Close savechanges:=False
    Set OutMail = Nothing
    Kill TempFilePath & TempFileName & FileExtStr
    
    Ash.AutoFilterMode = False  'Close AutoFilter
  Next ky
End Sub

 

[marcidee]

Thank you very much for your help - this looks to be working (using the second code)

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.