打開多個子文件夾，複製均優於它的文件到另一個文件夾 - VBA

Question

我想寫用VBA代碼應做到以下幾點：

我有一個包含5個文件夾的文件夾帕拉：塔塔，太特，Tutu，Toto，Titi 我想打開Para，然後打開Tata並複製所有的Excel文件夾，然後打開Tete並複製所有的Excel文件夾等。直到最後一個Titi。 我希望他們都在一個文件夾Para_Copy！ 有沒有可以做到的代碼？

我只在一個文件夾中有一個代碼（但desn't工作）：

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