Sub CopyFiles_Containing()
Dim fso As Object
Dim sSrcFolder As String, sTgtFolder As String, sFilename As String
Dim c As Range, d As Range, rPatterns As Range, jPatterns As Range
Dim bBad As Boolean
Dim File_Name As String
Dim subfolders As Object
dim dte as date
If ActiveSheet.Range("A9") = "" Then
MsgBox "No document to Search ", , "File Check"
Exit Sub
Else
' select Source folder prompt
' MsgBox
If MsgBox("Select Source folder", vbOKCancel, "Source folder") <> vbOK Then
Exit Sub
End If
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "File Path"
.AllowMultiSelect = False
If .Show = -1 Then ' if OK is pressed
sSrcFolder = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
' select target folder prompt
If MsgBox("Select destination folder", vbOKCancel, "Target Folder") <> vbOK Then
Exit Sub
End If
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.AllowMultiSelect = False
If .Show = -1 Then ' if OK is pressed
sTgtFolder = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Set rPatterns = ActiveSheet.Range("A9:B200").SpecialCells(xlConstants)
For Each c In rPatterns
sFilename = Dir(sSrcFolder & "*" & c.Text & "*")
If sFilename = "" Then
c.Interior.ColorIndex = 3
bBad = True
Else
While sFilename <> ""
dte = FileDateTime(sSrcFolder & sFilename)
dte = DateValue(dte & "")
If dte >= ActiveSheet.Range('starting date range here) and _
dte <= ActiveSheet.Range('ending date range here) then
FileCopy sSrcFolder & sFilename, sTgtFolder & sFilename
End If
sFilename = Dir()
Wend
End If
Next c
If bBad Then MsgBox "Some files were not found. " & _
"These were highlighted Red for your reference."
End If
End Sub
