Question

我正在尝试使用VBA编写代码，该代码应执行以下操作：

我有一个包含5个文件夹的文件夹：Tata，Tete，Tutu，Toto，Titi 我想打开Para，然后打开Tata并复制所有excel文件夹，然后打开Tete并复制所有Excel文件夹等..直到最后一个Titi。我希望他们都在一个文件夹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

打开多个子文件夹并将其中的所有excel文件复制到另一个文件夹-VBA

1 个答案: