Find files in folder where part of file name match Range and attach to Mail.

[ANDREAAS]

Hi All

So, if the macro below finds a "Yes" in

Sheets("Data Input").Range("O:O")

and the value in that range is "1234" for instance then i want all files in the specified folder where the file name contains 1234 to me attached to the mail.

So even if the file name is "what a good 1234 day it is", that will be attached to the mail as it contains 1234.

There are PDF and Excel files in the folder.

Sub Approval_Mail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In Worksheets("Data Input").Columns("Q").Cells
        Set OutMail = OutApp.CreateItem(0)
        If cell.Value = "YES" Then
            With OutMail
    .To = Worksheets("Data Input").Range("A55").Value & ";" & Worksheets("Data Input").Range("A54").Value
      .Subject = Cells(cell.Row, "Q").Offset(-1, -1).Value & " " _
        & Cells(cell.Row, "Q").Offset(0, -1).Value & " \ " _
          & Cells(cell.Row, "Q").Offset(-1, -13).Value & " " _
            & Cells(cell.Row, "Q").Offset(0, -13).Value
.Body = "Good Day" & " " & " Mr. " & Application.UserName & vbNewLine & vbNewLine & _
  "Please see below and attached for your approval." & vbNewLine & "----------------------------------------------------------------------" & vbNewLine _
   & Cells(cell.Row, "Q").Offset(-1, -13).Value & " --> " & Cells(cell.Row, "Q").Offset(0, -13).Value _
    & vbNewLine & vbNewLine & Cells(cell.Row, "Q").Offset(-1, -12).Value & " --> " & Cells(cell.Row, "Q").Offset(0, -12).Value _
     & vbNewLine & vbNewLine & Cells(cell.Row, "Q").Offset(-1, -11).Value & " --> " & Cells(cell.Row, "Q").Offset(0, -11).Value _
      & vbNewLine & vbNewLine & Cells(cell.Row, "Q").Offset(-1, -10).Value & " --> " & Cells(cell.Row, "Q").Offset(0, -10).Value _
      & vbNewLine & vbNewLine & Cells(cell.Row, "Q").Offset(-1, -9).Value & " --> " & Cells(cell.Row, "Q").Offset(0, -9).Value _
    & vbNewLine & vbNewLine & Cells(cell.Row, "Q").Offset(-1, -8).Value & " --> " & Cells(cell.Row, "Q").Offset(0, -8).Value _
   & vbNewLine & vbNewLine & Cells(cell.Row, "Q").Offset(-1, -7).Value & " --> " & Cells(cell.Row, "Q").Offset(0, -7).Value _
 & vbNewLine & vbNewLine & Cells(cell.Row, "Q").Offset(-1, -2).Value & " --> " & Cells(cell.Row, "Q").Offset(0, -2).Value _
& vbNewLine & "----------------------------------------------------------------------" & vbNewLine & "Thank You."
                .display

            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    Application.ScreenUpdating = True

End Sub

Thanks in advance for any help.