使用vba从多个子文件夹复制文件

Question

I've seen some documentation on this but so far, nothing that I've been able to replicate for my specific project.

My code points at a directory that contains 60 or so subfolders. Within these subfolders are multiple files .PDF/.XLS etc. The following code works fine if the files are not embedded in the subfolders but what I need to do is be able to loop through the subfolders and pull the files themselves to move. Also, is there a way to eventually pull files by wildcard name? Thanks in advance for any help.

  Dim FSO As Object
  Dim FromPath As String
  Dim ToPath As String
  Dim Fdate As Date
  Dim FileInFromFolder As Object

  FromPath = "H:\testfrom\"
  ToPath = "H:\testto\"

  Set FSO = CreateObject("scripting.filesystemobject")
  For Each FileInFromFolder In FSO.getfolder(FromPath).Files
  Fdate = Int(FileInFromFolder.DateLastModified)
      If Fdate >= Date - 1 Then

        FileInFromFolder.Copy ToPath

    End If
Next FileInFromFolder
End Sub

Answer 1

You can also use recursion. Your folder can have subfolders having subfolders having ...

Public Sub PerformCopy()
    CopyFiles "H:\testfrom\", "H:\testto\"
End Sub


Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String)
    Set FSO = CreateObject("scripting.filesystemobject")
    'First loop through files
    For Each FileInFromFolder In FSO.getfolder(strPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        If Fdate >= Date - 1 Then
            FileInFromFolder.Copy strTarget
        End If
    Next FileInFromFolder 


    'Next loop throug folders
    For Each FolderInFromFolder In FSO.getfolder(strPath).SubFolders
        CopyFiles FolderInFromFolder.Path, strTarget
    Next FolderInFromFolder
End Sub

Answer 2

I managed to get this code to work. It copies all folders / files and sub folders and their files to the new destination (strTarget).

I have not added checks and balances like 1) if the files and folders exist already. 2) if the source files are open etc. So those additions could be useful.

I got this code from Barry's post but needed to change it to make it work for me, so thought i'd share it again anyway.

Hope this is useful though. . .

strPath is the source path and strTarget is the destination path. both paths should end in '\\'

Note: one needs to add "Microsoft Scripting Runtime" under "Tools / References" for FSO to work.

==================== call ================================
MkDir "DestinationPath"

CopyFiles "SourcePath" & "\", "DestinationPath" & "\"

==================== Copy sub ===========================

Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String)
Dim FSO As Object
Dim FileInFromFolder As Object
Dim FolderInFromFolder As Object
Dim Fdate As Long
Dim intSubFolderStartPos As Long
Dim strFolderName As String

Set FSO = CreateObject("scripting.filesystemobject")
'First loop through files
    For Each FileInFromFolder In FSO.GetFolder(strPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'If Fdate >= Date - 1 Then
            FileInFromFolder.Copy strTarget
        'end if
    Next

    'Next loop throug folders
    For Each FolderInFromFolder In FSO.GetFolder(strPath).SubFolders
        'intSubFolderStartPos = InStr(1, FolderInFromFolder.Path, strPath)
        'If intSubFolderStartPos = 1 Then

        strFolderName = Right(FolderInFromFolder.Path, Len(FolderInFromFolder.Path) - Len(strPath))
        MkDir strTarget & "\" & strFolderName

        CopyFiles FolderInFromFolder.Path & "\", strTarget & "\" & strFolderName & "\"

    Next 'Folder

End Sub

Answer 3

I found the solution here:

 Private Sub Command3_Click()

Dim objFSO As Object 'FileSystemObject
Dim objFile As Object 'File
Dim objFolder As Object 'Folder
Const strFolder As String = "H:\testfrom2\"
Const strNewFolder As String = "H:\testto\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFolder In objFSO.GetFolder(strFolder & "\").SubFolders
    'If Right(objFolder.Name, 2) = "tb" Then
        For Each objFile In objFolder.Files
            'If InStr(1, objFile.Type, "Excel", vbTextCompare) Then
                On Error Resume Next
    Kill strNewFolder & "\" & objFile.Name
 Err.Clear: On Error GoTo 0

                Name objFile.Path As strNewFolder & "\" & objFile.Name
            'End If
        Next objFile
    'End If
Next objFolder


End Sub