After hours of searching I am totally exhausted....hopefully I articulate my situation for some assistance.
Looking for a VBA code to do the following...found lots of examples that address a couple of aspects of what I am trying to accomplish, however cannot tie them all together...ok lets go lol
I have a list of file names in column A 123.pdf or 123.xls So on and so forth (it doesnt matter)
I would like the code to search a number of sub folders off the root folder for those files (in column A) and when found copy them to a folder I designate
I found this code i altered that works perfect however only works at the root and does not search within the sub folders...
Sub SEARCH_COPY_FILES()
Dim r As Range
Dim SourcePath As String, DestPath As String, FName As String
'Setup source and dest path (Note: must have a trailing backslash!)
SourcePath = "**************\"
DestPath = "****************\"
'Visit each used cell in column A
For Each r In Range("A1", Range("A" & Rows.Count).End(xlUp))
'Search the file with the file mask from the cell (Note: can contain wildcards like *.xls)
FName = Dir(SourcePath & r)
'Loop while files found
Do While FName <> ""
'Copy the file
FileCopy SourcePath & FName, DestPath & FName
'Search the next file
FName = Dir()
Loop
Next
End Sub
***then found this code which does search the subs however only for one file or type of file (*.pdf) which again works...
Sub CopyFiles()
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String
Dim sDestinationPath As String
Dim sFileType As String
Dim bContinue As Boolean
bContinue = True
iRow = 2
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "\\*********************\"
sDestinationPath = "\\******************\"
sFileType = "" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
While bContinue
If Len(Range("A" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
MsgBox "Process executed" ' DONE.
bContinue = False
Else
' CHECK IF FILES EXISTS.
If Len(Dir(sSourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("C" & CStr(iRow)).Value = "Does Not Exists"
Range("C" & CStr(iRow)).Font.Bold = True
Else
Range("C" & CStr(iRow)).Value = "COPIED"
Range("C" & CStr(iRow)).Font.Bold = False
If Trim(sDestinationPath) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")
' CHECK IF DESTINATION FOLDER EXISTS.
If objFSO.FolderExists(sDestinationPath) = False Then
MsgBox sDestinationPath & " Does Not Exists"
Exit Sub
End If
'*****
' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.
' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
objFSO.CopyFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
'objFSO.MoveFile Source:=sSourcePath & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
'*****
End If
End If
End If
iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub
I surrender...please someone out there help me out with this...I am sure it is something simple and hope that I explained my predicament.
Vicco
Bookmarks