Sub PdfMove(path As String, dpath As String)
Dim currPath As String
Dim dirCollection As Collection
Dim fileCollection As Collection
Dim directory As Variant, pdffile As Variant, fnArry() As Variant
Dim lRow As Long, i As Long, j As Long
Set dirCollection = New Collection
Set fileCollection = New Collection
lRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
fnArry = Sheet1.Range("A2:A" & lRow)
currPath = Dir(path, vbDirectory)
'loop through current path and add pdf files to file collection and subfolders to directory collection
Do Until currPath = vbNullString
If InStr(currPath, ".pdf") > 0 Then
fileCollection.Add path & currPath
End If
If Left(currPath, 1) <> "." And _
(GetAttr(path & currPath) And vbDirectory) = vbDirectory Then
dirCollection.Add currPath
End If
currPath = Dir()
Loop
'Explore subfolders
For Each directory In dirCollection
PdfMove path & directory & "\", dpath
Next directory
'Using fileCollection copy files, to move files replace FileCopy line with below
'Name fileCollection(j) As dpath & pdffile
For i = LBound(fnArry, 1) To UBound(fnArry, 1)
findString = fnArry(i, 1)
For j = 1 To fileCollection.Count
If InStr(fileCollection(j), fnArry(i, 1)) > 0 Then
Sheet1.Cells(i + 1, 2) = fileCollection(j)
pdffile = Split(fileCollection(j), "\")
pdffile = Trim(pdffile(UBound(pdffile)))
FileCopy fileCollection(j), dpath & pdffile
End If
Next j
Next i
End Sub
Sub Test1()
' First is parent directory for all files, second is destination folder
' There is no error check so make sure you have the destination folder created beforehand
PdfMove "C:\Test\", "C:\Test\Destination\"
End Sub
