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 FileInFromFolder 


    'Next loop throug folders
    For Each FolderInFromFolder In FSO.getfolder(strPath).SubFolders
        CopyFiles FolderInFromFolder.Path, strTarget
    Next FolderInFromFolder
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 Scripting Runtime”才能使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

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

3 个答案: