我想使用带有文件名列表的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