Send E-mail along with attachment based on Filename sktneer

Dim fso As Object
Dim folderPath As String
Dim Folder As Object
Dim File As Object
Dim fileName As String
Sub SendEmailWithAttachment()
Dim olApp As Object
Dim olEmail As Object
Dim rng As Range, cell As Range
Dim lr As Long

Application.ScreenUpdating = False

'Path of the folder containing pdf files
folderPath = Environ("UserProfile") & "\Desktop\infi\"

lr = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A2:A" & lr)

Set fso = CreateObject("Scripting.FileSystemObject")
Set olApp = CreateObject("Outlook.Application")

'Check if the Folder with pdf file exists
If Not fso.FolderExists(folderPath) Then
   MsgBox "Folder " & folderPath & " doesn't exist.", vbCritical, "Folder Not Found!"
   Exit Sub
End If
For Each cell In rng
   fileName = pdfFileName(cell.Value)
   If fileName <> "" Then
      With olApp.createitem(0)
         .to = cell.Offset(0, 1).Value
         .cc = cell.Offset(0, 2).Value
         .Subject = cell.Offset(0, 3).Value
         .body = Range("F1").Value
         .attachments.Add folderPath & fileName
         .SentOnBehalfOfName = Range("G2").Value
         '.send
         .display
      End With
   End If
Next cell
Application.ScreenUpdating = True
Set olApp = Nothing
Set fso = Nothing
End Sub

Function pdfFileName(vFileName As String) As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.getfolder(folderPath)
For Each File In Folder.Files
   If InStr(File.Name, vFileName) > 0 And fso.GetExtensionName(File.Name) = "pdf" Then
      pdfFileName = File.Name
      Exit For
   End If
Next File
End Function

Select allOpen in new window