Hi, I have a macro that attaches a sheet, but this month I need to have 2 attachments in the email.
For some reason I can't get my macro updated to do this. sample data and current macro below. In column C I've separated the the files to be sent with ;
Data-
Column A - [TABLE="width: 217"]
<tbody>[TR]
[TD="class: xl65, width: 217"]Surname, Name
Column B -
Recipient email
Column C -
K:\Finance Ops\Client Financial Services\SABIC\COMP\1. Monthly IPRs\IPRs To be sent\EFT_Alamiri_Mohammed_8255368_Jan_Allowances_IPR_UPDATED_DEC_BS_ALLOWANCE_AMOUNTS.xlsm; K:\Finance Ops\Client Financial Services\SABIC\COMP\BALANCE SHEETS\3. December 2017 & Forward Balance Sheets\31247_Mohammed Alharbi_December update benefits sheet_REPAT BATCH 1_SENT 16
Column D -
EFT_Surname_Name_8255368_Jan_Allowances_IPR_UPDATED_DEC_BS_ALLOWANCE_AMOUNTS.xlsm
Column E -
January
Column F (in text format) -
8255368
Column G -
19th January
Macro
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = Cells(cell.Row, 4).Value
.Body = "Please process the attached " & Cells(cell.Row, 5).Value & " IPR for" & Cells(cell.Row, 1).Value & " – File No: " & Cells(cell.Row, 6).Value & _
Chr(13) & "Kindly note that the PO should be SRF’d and paid on the " & Cells(cell.Row, 7).Value & _
Chr(13) & "Please direct any queries to sabic@bgrs.com"
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Thanks in advance
[/TD]
[/TR]
</tbody>[/TABLE]
For some reason I can't get my macro updated to do this. sample data and current macro below. In column C I've separated the the files to be sent with ;
Data-
Column A - [TABLE="width: 217"]
<tbody>[TR]
[TD="class: xl65, width: 217"]Surname, Name
Column B -
Recipient email
Column C -
K:\Finance Ops\Client Financial Services\SABIC\COMP\1. Monthly IPRs\IPRs To be sent\EFT_Alamiri_Mohammed_8255368_Jan_Allowances_IPR_UPDATED_DEC_BS_ALLOWANCE_AMOUNTS.xlsm; K:\Finance Ops\Client Financial Services\SABIC\COMP\BALANCE SHEETS\3. December 2017 & Forward Balance Sheets\31247_Mohammed Alharbi_December update benefits sheet_REPAT BATCH 1_SENT 16
Column D -
EFT_Surname_Name_8255368_Jan_Allowances_IPR_UPDATED_DEC_BS_ALLOWANCE_AMOUNTS.xlsm
Column E -
January
Column F (in text format) -
8255368
Column G -
19th January
Macro
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = Cells(cell.Row, 4).Value
.Body = "Please process the attached " & Cells(cell.Row, 5).Value & " IPR for" & Cells(cell.Row, 1).Value & " – File No: " & Cells(cell.Row, 6).Value & _
Chr(13) & "Kindly note that the PO should be SRF’d and paid on the " & Cells(cell.Row, 7).Value & _
Chr(13) & "Please direct any queries to sabic@bgrs.com"
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Thanks in advance
[/TD]
[/TR]
</tbody>[/TABLE]