VBA to copy files that contain certain text within filename from one folder to another

Hi All,

I need a VBA that can go through a certain folder and copy files that contain a certain text into another folder. For example.

I have 100 PDF files in 'FOLDER A'

I need to go through 'FOLDER A' and find the PDF files that contain the word 'Sydney' and copy it in folder called 'FOLDER - Sydney'. Then find the files that contain the word 'Melbourne and copy it into 'FOLDER - Melbourne', and so on untill i have completed the string requirements.

If you can help me with this it would be great!!!!


Thanks Guys!



Below is a VBA i tried to manipulate, however it did not work and dont know how to loop it into another target folder.

sSrcFolder = ActiveSheet.Cells(2, 1) - Folder with all files
sTgtFolder = ActiveSheet.Cells(2, 2) - Folder to copy into
Set rPatterns = ActiveSheet.Range("E2:E15")

- list of words i was looking for.

Sub CopyFiles_Containing()
    Dim sSrcFolder As String, sTgtFolder As String, sFilename As String
    Dim c As Range, rPatterns As Range
    Dim bBad As Boolean
    
    sSrcFolder = ActiveSheet.Cells(2, 1)
    sTgtFolder = ActiveSheet.Cells(2, 2)
    
    Set rPatterns = ActiveSheet.Range("E2:E15").SpecialCells(xlConstants)
    For Each c In rPatterns
        sFilename = Dir(sSrcFolder & "*" & c.Text & "*")
        If sFilename = "" Then
            c.Interior.ColorIndex = 3
            bBad = True
        Else
            While sFilename <> ""
                FileCopy sSrcFolder & sFilename, sTgtFolder & sFilename
                sFilename = Dir()
            Wend
        End If
    Next c
    If bBad Then MsgBox "Some files were not found. " & _
        "These were highlighted for your reference."
End Sub

Sub copyfile()
Set fs = CreateObject("Scripting.FileSystemObject")
oldpath = "C:\FOLDER A"
newpath = "C:\FOLDER - Sydney"
Set f = fs.getfolder(oldpath)
Set NFile = f.Files
For Each pf1 In NFile
  NameFile = pf1.Name
  If InStr(NameFile, "Sydney") > 0 Then
    filecopy oldpath & "\" & NameFile, newpath & "\" & NameFile
  End If
Next
End Sub

Sub copyfile()
Set fs = CreateObject("Scripting.FileSystemObject")
oldpath = inputbox ("Source path ")
newpath =  inputbox ("Destination path ")
wordtofind = inputbox ("Word to find ")
Set f = fs.getfolder(oldpath)
Set NFile = f.Files
For Each pf1 In NFile
  NameFile = pf1.Name
  If InStr(NameFile, wordtofind) > 0 Then
    filecopy oldpath & "\" & NameFile, newpath & "\" & NameFile
  End If
Next
End Sub