VBA - Send email with attachments to range (row by row)

[chachis1961]

Hi,

I have a spreadsheet which I seek to list client email address details etc. Due to a shortfall in our finance system. I seek to email attachments based on this info.

I am having difficulty getting code to attach the specified attachments to emails (attachments are specified in Columns I:K) and commence from row 3.

I have coloured the section I believe may be the issue red. Any assistance appreciated.

Code is:
Sub SendEmailWithAttachmentsWhenDueDateElapsed()
'Macro created by Mitchell Wilson
'Working on updating this macro 23/02/2018 1038hrs


Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim sSendTo As String
Dim sSendCC As String
Dim sSendBCC As String
Dim sSubject As String
Dim sTemp As String
Dim vDB As Variant



Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon


vDB = Sheet1.Range("a3").CurrentRegion


For lRow = 2 To UBound(vDB, 1)


If vDB(lRow, 3) = "" Then Exit Sub Else
If vDB(lRow, 7) <> "Sent" Then
If vDB(lRow, 6) <= Date Then
Set OutMail = OutApp.CreateItem(0)
sSendTo = vDB(lRow, 3)
sSendCC = vDB(lRow, 4)
sSubject = Range("A2") & vDB(lRow, 1) & " " & Range("N8").Value


On Error Resume Next
With OutMail
.To = sSendTo
.CC = sSendCC
.BCC = sSendBCC
If sSendCC > "" Then .CC = sSendCC
If sSendBCC > "" Then .BCC = sSendBCC
.Subject = sSubject
.Importance = 2



Dim FileCell As Range
Dim sh As Worksheet
Dim rng As Range

Set FileCell = vDB.Range(lRow, 9).Value & ";" & vDB.Range(lRow, 10).Value & ";" & vDB.Range(lRow, 11).Value
Set sh = Sheets("Sheet1")
Set rng = sh.Cells(cell.Row, 1).Range("I3:K60")


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





sTemp = Range("L10").Value & vbCrLf & vbCrLf
sTemp = sTemp & Range("L11").Value & Range("N7").Value & ". " & vbCrLf & vbCrLf
' Assumes project name is in column B
sTemp = sTemp & " For the " & Cells(lRow, 2) & vbCrLf & vbCrLf
sTemp = sTemp & Range("L12").Value & vbCrLf & vbCrLf
sTemp = sTemp & Range("L13").Value & vbCrLf & vbCrLf
'sTemp = sTemp & Range("L14").Value & vbCrLf & vbCrLf
sTemp = sTemp & Range("L15").Value & vbCrLf & vbCrLf
sTemp = sTemp & Range("L16").Value & vbCrLf
sTemp = sTemp & Range("L17").Value & vbCrLf
sTemp = sTemp & Range("L18").Value & vbCrLf
sTemp = sTemp & Range("L19").Value & vbCrLf
sTemp = sTemp & Range("L20").Value & vbCrLf
sTemp = sTemp & Range("L21").Value & vbCrLf
sTemp = sTemp & Range("L22").Value & vbCrLf
sTemp = sTemp & Range("L23").Value & vbCrLf


.Body = sTemp
' Change the following to .Send if you want to
' send the message without reviewing first
'.Save
.Display
End With

Set OutMail = Nothing

Workbook.Select ("Send Email with Attachments When Due Date Elapsed")
ActiveSheet.Select

Cells(lRow, 7).Value = "Sent"
Cells(lRow, 8).Value = Now()

End If
End If
Next lRow
Set OutApp = Nothing


MsgBox Range("N5").Value & "E-mails have been sent. "


'Sheet1.Range("a2").Resize (UBound(vDB, 1), UBound(vDB, 2)) = vDB


End Sub