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

Question

我已经看到了一些关于此的文档，但到目前为止，我没有能够复制我的特定项目。

我的代码指向一个包含60个左右子目录的目录。在这些子文件夹中有多个文件.PDF/.XLS等。如果文件未嵌入子文件夹中，以下代码可以正常工作，但我需要做的是能够循环访问子文件夹并将文件自身移动。另外，有没有办法最终通过通配符名称来提取文件？预先感谢您的帮助。

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

您还可以使用递归。您的文件夹可以有子文件夹有子文件夹...

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 loop throug folders 
    For Each FolderInFromFolder In FSO.getfolder(strPath).SubFolders 
     CopyFiles FolderInFromFolder.Path, strTarget 
    Next Folder 
End Sub 

Answer 2

我发现这里的解决方案：

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 

Answer 3

我设法让此代码工作。它将所有文件夹/文件和子文件夹及其文件复制到新目标（strTarget）。

如果文件和文件夹已经存在，我还没有像1）那样添加检查和余额。 2）如果源文件是开放的等所以这些增加可能是有用的。

我从Barry的帖子中得到了这段代码，但需要改变它以使其适用于我，所以我认为我会再次分享它。

希望这是有用的，但。 。 。

strPath是源路径，strTarget是目标路径。两个路径应以'\'结尾

注意：需要在“工具/参考”下的“Microsoft脚本运行时”添加FSO才能正常工作。

==================== 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