Блог

Я хотел бы использовать документ Excel со списком имен файлов для копирования файлов, перечисленных из нескольких папок, в одну папку назначения.

Приведенный ниже код работает, однако существует 150 папок, и я не хочу называть каждую из них.

Как мне искать файлы во всех папках в каталоге? Я надеялся, что смогу заменить «O:96 » с помощью «O: *», но подстановочные знаки, похоже, не работают для папок. Большинство имен папок представляют собой числа в диапазоне от 10-200, однако некоторые из них являются текстовыми.

Как я могу указать функцию копирования файлов для всех папок на диске O?

 Sub CopyFiles_Fd1_to_Fd2()
    
    Dim i As Long
    
    On Error Resume Next
    MkDir "C:PACKAGED DWGS"
    On Error GoTo 0
    
    For i = 1 To 5000
        FileCopy "O:95" amp; Sheets(1).Cells(i, 1).Value, "C:PACKAGED DWGS" amp; Sheets(1).Cells(i, 1).Value
        On Error Resume Next
        FileCopy "O:96" amp; Sheets(1).Cells(i, 1).Value, "C:PACKAGED DWGS" amp; Sheets(1).Cells(i, 1).Value
        On Error Resume Next
        FileCopy "O:97" amp; Sheets(1).Cells(i, 1).Value, "C:PACKAGED DWGS" amp; Sheets(1).Cells(i, 1).Value
        On Error Resume Next
        FileCopy "O:98" amp; Sheets(1).Cells(i, 1).Value, "C:PACKAGED DWGS" amp; Sheets(1).Cells(i, 1).Value
        On Error Resume Next
    Next
    
End Sub
 

«Компаньоны» среды выполнения сценариев Microsoft

• Отрегулируйте значения в разделе константы.
• Используя VBE>Tools>References , создайте ссылку на Microsoft Scripting Runtime .

Кодекс

 Option Explicit

' VBE-Tools-References-Microsoft Scripting Runtime
Sub copyFiles()
    
    ' Define constants.
    Const srcDrive As String = "O"
    Const dstPath As String = "C:PACKAGED DWGS"
    Const wsName As String = "Sheet1"
    Const First As String = "A2"
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Write file names from worksheet to Files Data array.
    Dim FilesData As Variant
    With wb.Worksheets(wsName)
        FilesData = .Range(First).Resize(.Cells(.Rows.Count, _
            .Range(First).Column).End(xlUp).Row - .Range(First).Row   1)
    End With
    'Debug.Print Join(Application.Transpose(Data), vbLf)
 
    ' Create a list of files (Dictionary) to be copied.
    Dim dict As Scripting.Dictionary
    Set dict = New Dictionary
    Dim fso As Scripting.FileSystemObject
    Set fso = New FileSystemObject
    Dim fsoDrive As Drive
    Set fsoDrive = fso.GetDrive(srcDrive)
    Dim fsoFolder As Folder
    Dim fsoFile As File
    Dim cMatch As Variant
    For Each fsoFolder In fsoDrive.RootFolder.SubFolders
        If fsoFolder.Attributes <> 22 Then ' exclude Recycle Bin and Sys.Inf.
            For Each fsoFile In fsoFolder.Files
                cMatch = Application.Match(fsoFile.Name, FilesData, 0)
                If Not IsError(cMatch) Then
                    If Not dict.Exists(fsoFile.Name) Then ' ensure unique.
                        dict(fsoFile.Name) = fsoFile.Path
                    End If
                End If
            Next fsoFile
        End If
    Next fsoFolder
    'Debug.Print Join(dict.Keys, vbLf) amp; Join(dict.Items, vbLf)
    
    ' Copy files to destination path.
    If Not fso.FolderExists(dstPath) Then
        MkDir dstPath
    End If
    Dim Key As Variant
    For Each Key In dict.Keys
        'On Error Resume Next
        fso.CopyFile dict(Key), dstPath amp; "" amp; Key
        'On Error GoTo 0
    Next Key
    wb.FollowHyperlink dstPath

End Sub