将文件列表从多个文件夹复制到一个目标文件夹



我想使用带有文件名列表的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" & Sheets(1).Cells(i, 1).Value, "C:PACKAGED DWGS" & Sheets(1).Cells(i, 1).Value
On Error Resume Next
FileCopy "O:96" & Sheets(1).Cells(i, 1).Value, "C:PACKAGED DWGS" & Sheets(1).Cells(i, 1).Value
On Error Resume Next
FileCopy "O:97" & Sheets(1).Cells(i, 1).Value, "C:PACKAGED DWGS" & Sheets(1).Cells(i, 1).Value
On Error Resume Next
FileCopy "O:98" & Sheets(1).Cells(i, 1).Value, "C:PACKAGED DWGS" & Sheets(1).Cells(i, 1).Value
On Error Resume Next
Next

End Sub

Microsoft Scripting Runtime"Companions">

  • 调整常量部分中的值
  • 使用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) & 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 & "" & Key
'On Error GoTo 0
Next Key
wb.FollowHyperlink dstPath
End Sub

相关内容

  • 没有找到相关文章

最新更新