打開多個子文件夾並將其中的所有excel文件復制到另一個文件夾-VBA

Question

我正在嘗試使用VBA編寫代碼，該代碼應執行以下操作：

我有一個包含5個文件夾的Para文件夾：Tata，Tete，Tutu，Toto，Titi我想打開Para，然后打開Tata並復制其中的所有excel文件夾，然后打開Tete並復制所有的Excel文件夾等。一蒂蒂。 我希望將它們全部放在一個文件夾Para_Copy中！ 有沒有可以做到的代碼？

我僅在一個文件夾上有一個代碼（但無法使用）：

Sub sbCopyingAFile()
    'Declare Variables
    Dim FSO
    Dim sFile As String
    Dim sSFolder As String
    Dim sDFolder As String
    Dim myfile

    'This is Your File Name which you want to Copy
    sFile = "*.xls*"
    'Change to match the source folder path
    sSFolder = "Z:\Base_de_données\PARA\Toto\"
    ''Target Path with Ending Extention
    myfile = Dir(sSFolder & sFile)
    'Change to match the destination folder path
    sDFolder = "Z:\Base_de_données\Para_Copy"

    Do While myfile <> ""

        'Create Object
        Set FSO = CreateObject("Scripting.FileSystemObject")

        'Checking If File Is Located in the Source Folder
        If Not FSO.FileExists(myfile) Then
            MsgBox "Specified File Not Found", vbInformation, "Not Found"

        'Copying If the Same File is Not Located in the Destination Folder
        ElseIf Not FSO.FileExists(sDFolder & sFile) Then
            FSO.CopyFile (myfile), sDFolder, True
            MsgBox "Specified File Copied Successfully", vbInformation, "Done!"

        Else
            MsgBox "Specified File Already Exists In The Destination Folder", _
                vbExclamation, "File Already Exists"

        End If

        myfile = Dir()

    Loop

End Sub

謝謝您的幫助！ 干杯!

Answer 1

您想復制這些文件，而不是文件中的數據。 如果您是我，我將列出所有文件夾和子文件夾中的所有文件。

Sub GetFolder_Data_Collection()

Range("A:L").ClearContents
Range("A1").Value = "Name"
Range("B1").Value = "Path"
Range("C1").Value = "Size (KB)"
Range("D1").Value = "DateLastModified"
Range("E1").Value = "Attributes"
Range("F1").Value = "DateCreated"
Range("G1").Value = "DateLastAccessed"
Range("H1").Value = "Drive"
Range("I1").Value = "ParentFolder"
Range("J1").Value = "ShortName"
Range("K1").Value = "ShortPath"
Range("L1").Value = "Type"
Range("A1").Select

Dim strPath As String
'strPath = "I:\Information Security\KRI Monthly Data Collection\"
strPath = GetFolder

Dim OBJ As Object, Folder As Object, File As Object

Set OBJ = CreateObject("Scripting.FileSystemObject")
Set Folder = OBJ.GetFolder(strPath)

Call ListFiles(Folder)

Dim SubFolder As Object

For Each SubFolder In Folder.SubFolders
    Call ListFiles(SubFolder)
    Call GetSubFolders(SubFolder)
Next SubFolder


End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub ListFiles(ByRef Folder As Object)

On Error Resume Next
For Each File In Folder.Files
        ActiveCell.Offset(1, 0).Select
        ActiveCell = File.Name
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Offset(0, 1) = File.Path
            ActiveCell.Offset(0, 0).Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 0), Address:=File.Path, TextToDisplay:=File.Path
        ActiveCell.Offset(0, -1).Select
        ActiveCell.Offset(0, 2) = (File.Size / 1024) 'IN KB
        ActiveCell.Offset(0, 3) = File.DateLastModified
        ActiveCell.Offset(0, 4) = File.Attributes
        ActiveCell.Offset(0, 5) = File.DateCreated
        ActiveCell.Offset(0, 6) = File.DateLastAccessed
        ActiveCell.Offset(0, 7) = File.Drive
        ActiveCell.Offset(0, 8) = File.ParentFolder
        ActiveCell.Offset(0, 9) = File.ShortName
        ActiveCell.Offset(0, 10) = File.ShortPath
        ActiveCell.Offset(0, 11) = File.Type
Next File

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GetSubFolders(ByRef SubFolder As Object)

Dim FolderItem As Object
On Error Resume Next
For Each FolderItem In SubFolder.SubFolders
    Call ListFiles(FolderItem)
    Call GetSubFolders(FolderItem)
Next FolderItem

End Sub


Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

然后，運行一個小的腳本來執行復制/粘貼操作。 “ FromPath”來自使用上述腳本生成的路徑，“ ToPath”將是您選擇的任何內容。

Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\Ron\Data"  '<< Change
    ToPath = "C:\Users\Ron\Test"    '<< Change

    'If you want to create a backup of your folder every time you run this macro
    'you can create a unique folder with a Date/Time stamp.
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath

End Sub

https://www.rondebruin.nl/win/s3/win026.htm