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

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.

Hi All

Ok, so i found the macro below which looks like it might work, but i do not know how to incorporate it into my original macro that creates the mail.
Also on the macro below, the file type is defined as PDF and i would like for the macro to search for PDF as well as XLS & XLSM.

The part in red needs to be variable to fit with the original code(i think this would be something like

Cells(cell.Row, "Q").Offset(-1, -13).Value

?)

Any help would be much appreciated. Thanks in advance!

Option Explicit
Function findfiles(sPath, sFile As String) As Variant
    Dim fn, i
    fn = Dir(sPath & sFile & "*.pdf")
    If fn = "" Then Exit Function
    i = 0
    ReDim aFn(i)
    aFn(i) = fn
    Do While fn <> ""
        fn = Dir
        i = i + 1
        ReDim Preserve aFn(i)
        aFn(i) = fn
    Loop
    ReDim Preserve aFn(i - 1)
    findfiles = aFn
End Function
Sub test()
    Dim filenames, fn
    filenames = findfiles("C:\Users\Andreaas\Desktop\Orders\", "1276")
    If Not IsEmpty(filenames) Then
        For Each fn In filenames
           Debug.Print "C:\Users\Andreaas\Desktop\Orders\" & fn
        Next fn
    End If
End Sub

Incorporate this...

Sub sintek()
Dim File As Object, Path As String
Path = "E:\Sintek\Desktop\Folder\"  ' ! change to path that houses the files....
With CreateObject("Outlook.Application").CreateItem(0)
    .Display
    For Each File In CreateObject("Scripting.filesystemobject").getfolder(Path).Files
        If File.Name Like "*1234*.pdf" Or File.Name Like "*1234*.x*" Then .Attachments.Add (File)
    Next File
End With
End Sub

I am guessing this thread HERE is somehow connected...

Hi sintek

Yes they are connected, i just like to split the different questions up into separate parts to try make it easier for members searching for specific info.

Thank you very much. Will check out the code a bit later and let you know how it goes before i mark this solved.

Hi @sintek

So the code you provided works perfectly, but i am still stuck in an infinite loop and can't figure out why.

Below is the final code(with the loop error) if anyone is interested.

The code seems to never stop running and if i hit ESC then it debugs to this part :

If cell.Value = "YES" Then

Any ideas?

Final Code(with loop error) :

Sub Approval_Mail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim File As Object, Path As String
    Path = "C:\Users\Andreaas\Desktop\Orders\"  ' ! change to path that houses the files....
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
With CreateObject("Outlook.Application").CreateItem(0)
    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
For Each File In CreateObject("Scripting.filesystemobject").getfolder(Path).Files
        If File.Name Like "*1419*.pdf" Or File.Name Like "*1419*.x*" Then .Attachments.Add (File)
    Next File
End With

Sub Approval_Mail()
Dim File As Object, Path As String, cell As Range
Path = "C:\Users\Andreaas\Desktop\Orders\"  ' ! change to path that houses the files....
'Path = "E:\Sintek\Desktop\Folder\"
With Sheets("Data Input")
    For Each cell In .Range("Q2:Q" & .Cells(.Rows.Count, "Q").End(xlUp).Row) ' ! Loops row 2 to last row in Column Q
        If cell.Value = "YES" Then
            With CreateObject("Outlook.Application").CreateItem(0)
                .Display ' ! This ensures default outlook signature if any is shown...
                .To = ""
                .Body = ""
                '! You have a lot happening in the above....I am sure it can be simplified _
                  For that you will have to upload a sample file and explain what you are wanting to achieve here
                For Each File In CreateObject("Scripting.filesystemobject").getfolder(Path).Files
                    If File.Name Like "*1419*.pdf" Or File.Name Like "*1419*.x*" Then .Attachments.Add (File)
                Next File
                '! This loop above ... If the same files are being sent all the time can be executed only once before the cell loop and store the files in array to attach later...
                .Display '! Send
            End With
        End If
    Next cell
End With
End Sub

Awesome! Works perfectly thank you very much.

One last thing if i may.......

It's not the same files that are sent the whole time(forgot to mention, so i tried this :

If File.Name Like Cells(cell.Row, "Q").Value Or File.Name Like Cells(cell.Row, "Q").Value Then .Attachments.Add (File)

,but that does not work....

any ideas?

What is the value in cells(cell.row,"Q")...Does it include the extensions...Does it include a wildcard character "*"

Uploading a sample file depicting your actual files setup is always important...That way members can assist with actual code and not have to guesstimate...

the values will always be a number 4 to 8 digits and on occasion be preceded with a letter or 2 like QU.

busy creating a separate sheet to upload, will do so shortly....my original is waaaaaay too large to upload even if i do clean it up it.

If File.Name Like Cells(cell.Row, "Q").Value

check the value of each of the above as follows...
Just before the statement put

Debug.Print File.Name & " " & Cells(cell.Row, "Q").Value

This will depict the two values...
The like parameter searches a wildcard comparison... Which the two above will never have as the file extension is not included in your statement...

As per post 3...

 If File.Name Like "*1234*.pdf" Or File.Name Like "*1234*.x*" Then

Hi

See attached as requested.

the values will always be a number 4 to 8 digits and on occasion be preceded with a letter or 2 like QU.

You are confusing us now...Column Q has Yes or No...So are you trying to search for files with Yes or No names???

No, it searches for rows with Yes/No to determine opening a new mail or not and then searches the Offset value in Column P for the file to attach.

i.e. if there is yes in column P then create a new mail with the files of the "like" name in the same row in column p attached to that mail.

So why this in your code

If File.Name Like Cells(cell.Row, "Q").Value

this indicates file name as per Column Q

dummy mistake

should be

If File.Name Like Cells(cell.Row, "Q").offset(-1,0).Value

thanks for pointing that out.

sorry for the confusion

You are wanting this perhaps...Untested...

If File.Name Like "*" & cell.offset(,-1).value & "*.pdf" or File.Name Like "*" & cell.offset(,-1).value & "*.x*" then

yes thats it.

another mistake, i put (-1,0) above but it should be as you have it the other way around

the workbook is still giving a error though, so i don't think that i complited it correctly.

giving me end if without break if and same with, with.

Are not closing one of your condition statements...Don't have the file or code so cannot assist

hi

i attached the file a few posts up

see attached

Sub Approval_Mail()

    'Dim OutApp As Object...No Need...............
    'Dim OutMail As Object...No Need...............
    Dim File As Object, Path As String, cell As Range
    Path = "C:\Users\Andreaas Du Toit\Desktop\R&M Orders\"  ' ! change to path that houses the files....
    
    Application.ScreenUpdating = False
    
    'Set OutApp = CreateObject("Outlook.Application")...No Need...............
   
    For Each cell In Range("Q2:Q" & Cells(Rows.Count, "Q").End(xlUp).Row).SpecialCells(xlCellTypeVisible)  ' ! Loops row 2 to last row in Column Q
        If cell.Value = "YES" Then
            With CreateObject("Outlook.Application").CreateItem(0)
        'With OutMail ...No Need...............
                .To = ""
                ' Kept all the stuff out for this posting
                .Subject = ""
                For Each File In CreateObject("Scripting.filesystemobject").getfolder(Path).Files
                    If File.Name Like "*" & cell.Offset(, -1).Value & "*.pdf" Or File.Name Like "*" & cell.Offset(, -1).Value & "*.x*" Then
                Next File
                '! This loop above ... If the same files are being sent all the time can be executed only once before the cell loop and store the files in array to attach later...
                .Display '! Send
            End With
        End If
    Next cell
   
   Application.ScreenUpdating = True

End Sub

still giving "next without for" here :

 Next File

will you perhaps attach the workbook with the corrections in and highlight the corrections?

lol, not getting impatient....just worried i'm taking up too much of your time

Oops for got the attachments add snippet...

Sub Approval_Mail()
    Dim File As Object, Path As String, cell As Range
    Path = "C:\Users\Andreaas Du Toit\Desktop\R&M Orders\"
    Application.ScreenUpdating = False
    For Each cell In Range("Q2:Q" & Cells(Rows.Count, "Q").End(xlUp).Row)
        If cell.Value = "YES" Then
            With CreateObject("Outlook.Application").CreateItem(0)
                .To = ""
                .Subject = ""
                For Each File In CreateObject("Scripting.filesystemobject").getfolder(Path).Files
                    If File.Name Like "*" & cell.Offset(, -1).Value & "*.pdf" Or File.Name Like "*" & cell.Offset(, -1).Value & "*.x*" Then .Attachments.Add (File)
                Next File
                .Display '! Send
            End With
        End If
    Next cell
   Application.ScreenUpdating = True
End Sub

Cannot test right now and working from lounge Pc...No Outlook

cool, will try it again a bit later and let you know.....gotto run quickly for now

thank you very much so far sintek

Alright, so it's working now, but for some reason it changes the offset values for the body with each mail.

So in the code, the offset values stay the same but the first mail will give the correct values for :

Cells(cell.Row, "Q").Offset(-1, -13).Value & " --> " & Cells(cell.Row, "Q").Offset(0, -13).Value _

then the next mail that opens will show as if the code has moved one over on the offset to :

Cells(cell.Row, "Q").Offset(0, -12).Value & " --> " & Cells(cell.Row, "Q").Offset(1, -12).Value _

the next mail after than moves one more and so on.

What would be the reason for that?

Cells(cell.Row, "Q").Offset(-1, -13).Value

Lets assume the loop is in row 5...the above code takes the value from [D6] ... .Offset(-1, -13) means 1 row below , 13 columns to Left
as you are looping cells in column "Q"
this snippet

Cells(cell.Row, "Q").value

is actually

cell.value

so if you want to get a value within that same row...make use of the offset values i.e.

cell.offset(,1) means 1 column to right same row...
cell.offset(,-1) means 1 column to left same row...
I assume you don't want to reference cells above or below active row so the row must not be referenced in the code...

I notice that you are wanting to reference your Headers in your Email body...make use of this snippet for that... i.e.

Cells(1, "Q") ' ! references row 1 in column Q

You are awesome sintek.

thank you very, very much!!!!!!

I'm so happy, i'll repeat that in Klingon..... nagh SoH, qatlho'qu'

..........................
THANKS.gif