Option Explicit
'****************************************************************************************************************'
'http://www.mrexcel.com/forum/excel-questions/746969-copying-all-xls-file-single-parent-directory.html#post3671065
' COPY ALL DESIRED EXTENSION FILES TO NEW PATH ***********'
'*********************************************************'
Sub MoveFiles()
DoEvents
Dim FSO As FileSystemObject: Set FSO = New FileSystemObject
Dim File1 As File
Dim Folder1 As Folder
Dim Folder2 As Folder
Dim Folder3 As Folder
Dim Folder4 As Folder
Dim Folder5 As Folder
Dim Folder6 As Folder
Dim Folder7 As Folder
Dim FindPoint As Integer
Dim FileExtension As String: FileExtension = InputBox("Please Enter File Extension you wish to copy", , "xls")
If FileExtension = "" Then MsgBox "You did not enter a file extension!", vbCritical: Exit Sub
Dim FROMPATH As String: FROMPATH = InputBox("Enter path from which you would like to transfer the data", "Data Mover")
Dim TOPATH As String: TOPATH = InputBox("Enter path to which you would like to transfer the data", "Data Mover")
If FROMPATH = "" Then MsgBox "From Path not entered!", vbCritical: Exit Sub
If TOPATH = "" Then MsgBox "To Path not entered!", vbCritical: Exit Sub
If Not FSO.FolderExists(FROMPATH) Then MsgBox "Folder inputted does not exist!", vbCritical: Exit Sub
If Not FSO.FolderExists(TOPATH) Then MsgBox "Folder inputted does not exist!", vbCritical: Exit Sub
If Right(FROMPATH, 1) <> Application.PathSeparator Then FROMPATH = FROMPATH & Application.PathSeparator
If Right(TOPATH, 1) <> Application.PathSeparator Then TOPATH = TOPATH & Application.PathSeparator
Set Folder1 = FSO.GetFolder(FROMPATH)
Set Folder2 = FSO.GetFolder(TOPATH)
On Error Resume Next
For Each File1 In Folder1.Files
FindPoint = InStrRev(File1.Name, ".") + 1
If Mid(File1.Name, FindPoint) = FileExtension Then
File1.Copy TOPATH & File1.Name, True
End If
Next
For Each Folder2 In Folder1.SubFolders
For Each File1 In Folder2.Files
FindPoint = InStrRev(File1.Name, ".") + 1
If Mid(File1.Name, FindPoint) = FileExtension Then
File1.Copy TOPATH & File1.Name, True
End If
Next
Next
For Each Folder2 In Folder1.SubFolders
For Each Folder3 In Folder2.SubFolders
For Each File1 In Folder3.Files
FindPoint = InStrRev(File1.Name, ".") + 1
If Mid(File1.Name, FindPoint) = FileExtension Then
File1.Copy TOPATH & File1.Name, True
End If
Next
Next
Next
For Each Folder2 In Folder1.SubFolders
For Each Folder3 In Folder2.SubFolders
For Each Folder4 In Folder3.SubFolders
For Each File1 In Folder4.Files
FindPoint = InStrRev(File1.Name, ".") + 1
If Mid(File1.Name, FindPoint) = FileExtension Then
File1.Copy TOPATH & File1.Name, True
End If
Next
Next
Next
Next
For Each Folder2 In Folder1.SubFolders
For Each Folder3 In Folder2.SubFolders
For Each Folder4 In Folder3.SubFolders
For Each Folder5 In Folder4.SubFolders
For Each File1 In Folder5.Files
FindPoint = InStrRev(File1.Name, ".") + 1
If Mid(File1.Name, FindPoint) = FileExtension Then
File1.Copy TOPATH & File1.Name, True
End If
Next
Next
Next
Next
Next
For Each Folder2 In Folder1.SubFolders
For Each Folder3 In Folder2.SubFolders
For Each Folder4 In Folder3.SubFolders
For Each Folder5 In Folder4.SubFolders
For Each Folder6 In Folder5.SubFolders
For Each File1 In Folder6.Files
FindPoint = InStrRev(File1.Name, ".") + 1
If Mid(File1.Name, FindPoint) = FileExtension Then
File1.Copy TOPATH & File1.Name, True
End If
Next
Next
Next
Next
Next
Next
For Each Folder2 In Folder1.SubFolders
For Each Folder3 In Folder2.SubFolders
For Each Folder4 In Folder3.SubFolders
For Each Folder5 In Folder4.SubFolders
For Each Folder6 In Folder5.SubFolders
For Each Folder7 In Folder6.SubFolders
For Each File1 In Folder7.Files
FindPoint = InStrRev(File1.Name, ".") + 1
If Mid(File1.Name, FindPoint) = FileExtension Then
File1.Copy TOPATH & File1.Name, True
End If
Next
Next
Next
Next
Next
Next
Next
If Err.Number <> 0 Then MsgBox "some files were not copied"
Err.Clear
On Error GoTo 0
Set FSO = Nothing
MsgBox "Done"
End Sub
