VBA code to Copy File Based on Keywords in File Name

[Parth13]

Hi,
I am trying to write a code which will copy files from one directory to other based on some keywords in File Name.
The keywords are specified in a range in the spreadsheet. The code should pick each keyword, search for files containing that keyword and copy all the files with that keyword in the name to the directory specified. If the keyword is not found, it highlights the cell in the range as red.
Here's the Code:

Sub CopyFiles()
Dim srcFOLDER As String
Dim tgtFOLDER As String
Dim fRNG      As Range
Dim fName     As Range
Dim BAD       As Boolean
srcFOLDER = ActiveSheet.Cells(4, 3)
tgtFOLDER = ActiveSheet.Cells(5, 3)   
 
Set fRNG = ActiveSheet.Range("E4:E2000").SpecialCells(xlConstants)
For Each fName In fRNG
If InStr(1, Dir(srcFOLDER), fName, vbTextCompare) Then 'Checking whether the file contain keywords in column
    
FileCopy srcFOLDER & "*" & fName & "*" & .Text, tgtFOLDER & "*" & fName & "*" & .Text 
 
Else
        fName.Interior.ColorIndex = 3
        BAD = True
    End If
Next fName
    
If BAD Then MsgBox "Some files were not found. These were highlighted for your reference."
End Sub

It works fine till it reaches copying section where I am getting error "Bad file name" or "Invalid Qualifier". If anyone could help correcting this one. Thanks.

 

[kbriaz]

yes, main folder & sub folders will always be created. I.e

Main directory

K:\London\Letter - 18.06.2015 ( today's date )

Sub directories will be
K:\London\Letter - 18.06.2015\C Letter
K:\London\Letter - 18.06.2015\D Letter

Many thanks.


code:

Sub CopyFiles_ContainingParts()
Dim lngLast As Long, lNdx As Long
Dim sSrcFolder As String, sTgtFolder As String, sFilename As String
Dim C As Range, rPatterns As Range
Dim bBad As Boolean, bFound As Boolean
Dim vParts As Variant

'--each of these parts will be tried in the pattern search
vParts = Array("C Letter", "D Letter")

sSrcFolder = ActiveSheet.Cells(4, 3)
sTgtFolder = ActiveSheet.Cells(5, 3)

Set rPatterns = ActiveSheet.Range("A2:B" & lngLast).SpecialCells(xlConstants)
For Each C In rPatterns
bFound = False

sSrcFolder = "C:\Users\" & Environ("username") & "\"
'--modify to reference folder created by macro, with today's date
sTgtFolder = "K:\London\"
For lNdx = LBound(vParts) To UBound(vParts)
sFilename = Dir(sSrcFolder & C.Text & "*" & vParts(lNdx) & "*")
If Len(sFilename) Then
bFound = True
While sFilename <> ""
FileCopy sSrcFolder & sFilename, sTgtFolder & sFilename
sFilename = Dir()
Wend
End If
Next lNdx

If bFound = False Then
bBad = True
C.Interior.ColorIndex = 3
End If
Next C
If bBad Then MsgBox "Some files were not found. " & _
"These were highlighted for your reference."
End Sub

 

[Jerry Sullivan]

Try...

Sub CopyFiles_ContainingParts()
 Dim lngLast As Long, lNdx As Long
 Dim sSrcFolder As String, sTgtFolder As String, sFilename As String
 Dim c As Range, rPatterns As Range
 Dim bBad As Boolean, bFound As Boolean, bFoldersOK As Boolean
 Dim vParts As Variant
 
 '--each of these parts will be tried in the pattern search
 vParts = Array("C Letter", "D Letter")

 sSrcFolder = ActiveSheet.Cells(4, 3)
 sTgtFolder = ActiveSheet.Cells(5, 3)
 
 lngLast = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
 Set rPatterns = ActiveSheet.Range("A2:B" & lngLast).SpecialCells(xlConstants)
 
 sSrcFolder = "C:\Users\" & Environ("username") & "\"
 
 '--create folders with today's date
 sTgtFolder = "K:\London\Letter - " & Format(Date, "dd.mm.yyyy")
 
 If bCreateFolder(sFolderPath:=sTgtFolder) Then
   If bCreateFolder(sFolderPath:=sTgtFolder & "\C Letter") Then
      If bCreateFolder(sFolderPath:=sTgtFolder & "\D Letter") Then
         bFoldersOK = True
      End If
   End If
 End If
 If bFoldersOK = False Then
   MsgBox "Could not create target folders"
   Exit Sub
 End If
  
 For Each c In rPatterns
   bFound = False

   For lNdx = LBound(vParts) To UBound(vParts)
      sFilename = Dir(sSrcFolder & c.Text & "*" & vParts(lNdx) & "*")
      If Len(sFilename) Then
         bFound = True
         While sFilename <> ""
             FileCopy sSrcFolder & sFilename, sTgtFolder & "\" _
               & vParts(lNdx) & "\" & sFilename
             sFilename = Dir()
         Wend
      End If
   Next lNdx
   
   If bFound = False Then
      bBad = True
      c.Interior.ColorIndex = 3
   End If
 Next c
 If bBad Then MsgBox "Some files were not found. " & _
    "These were highlighted for your reference."
End Sub

Private Function bCreateFolder(sFolderPath As String) As Boolean
'--checks if folder exists, if not attempts to create folder
'  returns True if folder sucessfully created or already existed.

 Dim fso As Object
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 If Not fso.FolderExists(sFolderPath) Then
   On Error Resume Next
   fso.CreateFolder (sFolderPath)
   On Error GoTo 0
 End If
 
 '--return value reports if folder now exists
 bCreateFolder = fso.FolderExists(sFolderPath)
 Set fso = Nothing
End Function

When posting code, please use code tags to preserve indenting.

 

[kbriaz]

Hi Jerry,

Trying to break the problem down. Using your code i tried making below macro:

So it creates a folder with todays date. Then make two more sub directories in this folder macro has just created ( one with today's date ).

For some reason its not working. i get 'Expected Array' error at 'bCreateFolder'.

Please help

Sub Create_folders()
'
Dim sSrcFolder As String
Dim sTgtFolder As String
Dim sFilename As String
Dim bBad As Boolean
Dim bFound As Boolean
Dim bFoldersOK As Boolean
Dim fsoObj As Object
Dim enddir
Dim TheDate As String


 
 
sSrcFolder = "C:\Users\" & Environ("username") & "\"
sTgtFolder = "K:\London\Letter - " & Format(Date, "dd.mm.yyyy")


'--create folders with today's date


TheDate = Format(Date, "DD.MM.YYYY")
enddir = ("K:\London\Letter -" & TheDate & "\")


Set fsoObj = CreateObject("Scripting.FileSystemObject")


With fsoObj
    If Not .FolderExists(enddir) Then
        .CreateFolder (enddir)
    End If
End With
   


Dim bCreateFolder As Boolean


Dim sFolderPath As String


sFolderPath = "K:\London\Letter - " & Format(Date, "dd.mm.yyyy")
  
 If bCreateFolder(sFolderPath:=sTgtFolder) Then
   If bCreateFolder(sFolderPath:=sTgtFolder & "\C Letter") Then
      If bCreateFolder(sFolderPath:=sTgtFolder & "\D Letter") Then
         bFoldersOK = True
      End If
   End If
 End If


 If bFoldersOK = False Then
   MsgBox "Could not create target folders"
   Exit Sub
 End If


'
End Sub

P.s After this folder macro, i will incorporate your copy file macro so C letter gets copied at

K:\London\Letter - " & Format(Date, "dd.mm.yyyy")\C Letter

& L letter gets copied at

K:\London\Letter - " & Format(Date, "dd.mm.yyyy")\L Letter

Thanks again & sorry for not using code tags.

 

[Jerry Sullivan]

The code in Post #32 includes a function named: bCreateFolder

Private Function bCreateFolder(sFolderPath As String) As Boolean
'--checks if folder exists, if not attempts to create folder
'  returns True if folder sucessfully created or already existed.

 Dim fso As Object
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 If Not fso.FolderExists(sFolderPath) Then
   On Error Resume Next
   fso.CreateFolder (sFolderPath)
   On Error GoTo 0
 End If
 
 '--return value reports if folder now exists
 bCreateFolder = fso.FolderExists(sFolderPath)
 Set fso = Nothing
End Function

The code in Post #32 already incorporates the creation of the folders and the copying of the files.

Have you tried using that code as is?

 

[kbriaz]

Hi Jerry,

Many thanks. All works perfectly now.

I am try to use the code on few other similar tasks, if i get stuck i might reply back ( hope that's ok )

You have been a great help - many thanks.

 

[Gokury]

Hi Jerry,

I am using your code in thread #18 , the only thing I would like to change in a way that it will work also if you do not haven numbers in the file names and I will need that to move the files based on partial file of the file names based of keys in column ''B ID ''.
Thanks for help,

Kind regards