Как я могу ходить по папкам и подпапкам и получать файлы с определенным типом файла, а затем копировать в другой каталог в VBA?

Question

Я хочу скопировать определенный тип файла (*. SLDDRW) из источника в место назначения, в пути назначения у нас много папок и подпапок. В приведенном ниже коде я пытаюсь пройтись по любым подпапкам, но, к сожалению, это не такне работает и не прошел все подпапки, ТАК может мне помочь?

Sub copy_specific_files_in_folder()
Dim FSO As Object
Dim sourcePath As String
Dim destinationPath As String 
Dim fileExtn As String

sourcePath = "C:\Users\6\"
destinationPath = "C:\Users\"

fileExtn = "*.SLDDRW"

If Right (sourcePath, 1) <> "\" Then
sourcePath = sourcePath & "\"
End If

Set FSO = CreateObject ("scripting.filesystemobject")
If FSO.FolderExists(sourcepath) = False  Then 
MsgBox sourcePath & " does not exist"

Exit Sub
End If

  FSO.CopyFile Source:=sourcePath & fileExtn, Destination :=destinationPath
  copy_files_from_subfolders
 MsgBox "Your files have been copied from the sub-folders of " & sourcePath
 End sub




 sub copy_files_from_subfolders()
 Dim FSO AS Object , fld As Object
 Dim fsoFile As Object
 Dim fsoFol As Object

 sourcePath = "C:\Users\6\"
 targetPath = "C:\Users\"

If Right (sourcePath , 1) <> "\"  then sourcePath = sourcePath & "\"
Set FSO = createObject("Scripting.FileSystemObject")
Set fld = FSO.getFolder(sourcePath)
If  FSO.FolderExists(fld)  Then 
    For Each fsoFol  In FSO.GetFolder(sourcePath).SubFolders
        For Each  fsoFile In fsoFol.Files
            If Right (fsoFile, 6)  = "sldprt" Then 
            fsoFile.Copy targetPath
            End If
         Next
      Next
 End If 

Answer 1

Вот функция, которая будет рекурсивно искать папку и все подпапки для определенного расширения, а затем копировать найденные файлы в указанное место назначения:

Sub SearchFoldersAndCopy(ByVal arg_sFolderPath As String, _
                         ByVal arg_sDestinationFolder As String, _
                         ByVal arg_sExtension As String)

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oSubFolder As Object
    Dim sTest As String

    'Test if FolderPath exists
    sTest = Dir(arg_sFolderPath, vbDirectory)
    If Len(sTest) = 0 Then
        MsgBox "Specified folder [" & arg_sFolderPath & "] doesn't exist.  Please check spelling or create the directory."
        Exit Sub
    End If

    'Test if Destination exists
    sTest = Dir(arg_sDestinationFolder, vbDirectory)
    If Len(sTest) = 0 Then
        MsgBox "Specified destination [" & arg_sDestinationFolder & "] doesn't exist.  Please check spelling or create the directory."
        Exit Sub
    End If

    'FolderPath and Destination both exist, proceed with search and copy
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(arg_sFolderPath)

    'Test if any files with the Extension exist in directory and copy if one or more found
    sTest = Dir(oFolder.Path & Application.PathSeparator & "*." & arg_sExtension)
    If Len(sTest) > 0 Then oFSO.copyfile oFolder.Path & Application.PathSeparator & "*." & arg_sExtension, arg_sDestinationFolder

    'Recursively search subfolders
    For Each oSubFolder In oFolder.SubFolders
        SearchFoldersAndCopy oSubFolder.Path, arg_sDestinationFolder, arg_sExtension
    Next oSubFolder

End Sub

Вот пример того, как его вызвать:

Sub tgr()

    Dim sStartFolder As String
    Dim sDestination As String
    Dim sExtension As String

    sStartFolder = "C:\Test"
    sDestination = "C:\Output\"    '<-- The ending \ may be required on some systems
    sExtension = "SLDDRW"

    SearchFoldersAndCopy sStartFolder, sDestination, sExtension

End Sub