问题描述
在过去的5天里，在这里和整个网上搜寻内容，可以找到适用于多个文件的内容。许多深夜/清晨未成功拼凑/编码以获取结果。预先感谢。
以下代码来自由Oscar编写的get-digital-help.com/copyrename-a-file-excel-vba 它适用于1个文件，我需要在一个深层文件夹结构中处理8,000个文件，所以我真的希望每一行都查看源路径，源文件名，目标路径和目标文件：
对于每一行：
E列写“成功”或“失败”验证。
很高兴拥有/完全可选！！！ ：）
Sub copyRenameFile()
'Dimension variables and declare data types
Dim src As String,dst As String,fl As String
Dim rfl As String
'Save source directory specified in cell A2 to variable src
src = Range("A2")
'Save destination directory specified in cell C2 to variable dst
dst = Range("C2")
'Save file name specified in cell B2 to variable fl
fl = Range("B2")
'Save new file name specified in cell D2 to variable rfl
rfl = Range("D2")
'Enable error handling
On Error Resume Next
'copy file based on variables src and fl to destination folder based on variable dst and name file based on value in rfl
Filecopy src & "\" & fl,dst & "\" & rfl
'Check if an error has occurred
If Err.Number <> 0 Then
'Show error using message Box
MsgBox "copy error: " & src & "\" & rfl
End If
'disable error handling
On Error GoTo 0
End Sub
解决方法
使用文件列表复制文件
-
此解决方案包含三个过程。您仅运行第一个：
copyRenameFile。必要时，另外两个getOffsetColumn和writeOffsetRange会被第一个调用。 -
最好在新工作簿上进行测试。插入一个模块并将代码复制到其中。现在打开原始工作簿，然后将某些值复制到新工作簿的
Sheet1。由于代码是为Thisworkbook（包含此代码的工作簿）编写的，因此原始工作簿将是安全的（不会写入）。 -
首先调整常量部分（标题为
Worksheet和Other）中的值。然后测试空的工作表。然后，对列A中的一个文件夹进行测试，然后对更多文件夹进行缓慢测试，然后继续对其他列进行测试。应该抑制可能的错误，并且它们的消息（描述）应该出现在VBE的{{1}}窗口（ CTRL + G ）中。 -
作为本次调查的副产品，我还添加了
Immediate函数，以在createFolders'不能'的情况下创建文件夹，并添加了两个过程对其进行测试。 >
代码
MkDir副产品
Option Explicit
Sub copyRenameFile()
' Initialize error handling.
Const ProcName As String = "copyRenameFile"
On Error GoTo clearError ' Turn on error trapping.
' Worksheet
Const wsName As String = "Sheet1" ' Worksheet Name
Const FirstRow As Long = 2 ' First Row Number
Const LastRowCol As Variant = "A" ' Last Row Column Index
Dim srcCols As Variant ' Source Columns Array
srcCols = VBA.Array("A","B","C","D")
Dim tgtCols As Variant ' Target Columns Array
tgtCols = VBA.Array("E","F")
' Other
Dim filMsg() As Variant ' File Messages
filMsg = VBA.Array("Fail","Success")
Dim folMsg() As Variant ' Folder Messages
folMsg = VBA.Array(False,True,"Duplicate")
Dim PathDelimiter As String
PathDelimiter = Application.PathSeparator
Dim wb As Workbook
Set wb = ThisWorkbook ' 'Thisworkbook' is the workbook containing this code.
' Define Last Row Column Range ('rng').
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count,LastRowCol).End(xlUp).Row
If LastRow < FirstRow Then
GoTo FirstRowBelowLastRow
End If
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow,LastRowCol),_
ws.Cells(LastRow,LastRowCol))
' Write Source Column Ranges to Source Jagged Array ('Source').
Dim ubcS As Long
ubcS = UBound(srcCols)
Dim Source As Variant
ReDim Source(0 To ubcS)
Dim Data As Variant
Dim j As Long
For j = 0 To ubcS
getOffsetColumn Data,srcCols(j),rng
Source(j) = Data
Next j
' Define Target Jagged Array ('Target').
Dim ubcT As Long
ubcT = UBound(tgtCols)
Dim ubs As Long
ubs = UBound(Source(0))
Dim Target As Variant
ReDim Target(0 To ubcT)
ReDim Data(1 To ubs,1 To 1)
For j = 0 To ubcT
Target(j) = Data
Next j
' Declare additional variables for the For Next loop.
Dim i As Long
Dim Copied As Long
Dim srcPath As String
Dim tgtPath As String
' Loop through rows of arrays of Source Jagged Array,check folders,' check files and finally copy if condition is met. At the same time
' write results to arrays of Target Jagged Array.
' The condition to copy is met when source file exists,' and target file does not.
For i = 1 To ubs
' Folders
srcPath = Source(0)(i,1)
If Dir(srcPath,vbDirectory) = "" Then
' Source Folder and Source File do not exist.
Target(0)(i,1) = filMsg(0)
Target(1)(i,1) = folMsg(0)
GoTo NextRow
End If
' Source Folder exists.
tgtPath = Source(1)(i,1)
If Dir(tgtPath,vbDirectory) = "" Then
' Target Folder and Target File do not exist.
Target(0)(i,1) = folMsg(0)
GoTo NextRow
End If
' Source Folder and Target Folder exist.
' Files
srcPath = srcPath & PathDelimiter & Source(2)(i,1)
If Dir(srcPath) = "" Then
' Source File does not exist.
Target(0)(i,1) = folMsg(0)
GoTo NextRow
End If
' Source File exists.
tgtPath = tgtPath & PathDelimiter & Source(3)(i,1)
If Dir(tgtPath) <> "" Then
' Target File exists.
Target(0)(i,1) = folMsg(2)
GoTo NextRow
End If
' Source File exists and Target File does not.
Target(0)(i,1) = filMsg(1)
Target(1)(i,1) = folMsg(1)
' Copy
FileCopy srcPath,tgtPath
' Count files copied.
Copied = Copied + 1
NextRow:
Next i
' Write values (results) from arrays of Target Jagged Array
' to Target Columns.
For j = 0 To ubcT
writeOffsetRange Target(j),tgtCols(j),rng
Next j
' Inform user.
MsgBox "Copied " & Copied & " files.",vbInformation,"Success"
ProcExit:
Exit Sub
FirstRowBelowLastRow:
Debug.Print "'" & ProcName & "': First row below last row."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
Sub getOffsetColumn(ByRef Data As Variant,_
OffsetColumnIndex As Variant,_
ColumnRange As Range)
' Initialize error handling.
Const ProcName As String = "getOffsetColumn"
On Error GoTo clearError ' Turn on error trapping.
Data = Empty
If ColumnRange Is Nothing Then
GoTo NoRange
End If
Dim ws As Worksheet
Set ws = ColumnRange.Worksheet
If ColumnRange.Rows.Count > 1 Then
Data = ColumnRange.Offset(,ws.Columns(OffsetColumnIndex).Column _
- ColumnRange.Column) _
.Value
Else
ReDim Data(1 To 1,1 To 1)
Data(1,1) = ColumnRange.Offset(,ws.Columns(OffsetColumnIndex) _
.Column _
- ColumnRange.Column) _
.Value
End If
ProcExit:
Exit Sub
NoRange:
Debug.Print "'" & ProcName & "': No Range."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
Sub writeOffsetRange(Data As Variant,_
OffsetColumnIndex As Variant,_
ColumnRange As Range)
' Initialize error handling.
Const ProcName As String = "writeOffsetColumn"
On Error GoTo clearError ' Turn on error trapping.
If ColumnRange Is Nothing Then
GoTo NoRange
End If
Dim ws As Worksheet
Set ws = ColumnRange.Worksheet
ColumnRange.Offset(,ws.Columns(OffsetColumnIndex).Column _
- ColumnRange.Column).Value = Data
ProcExit:
Exit Sub
NoRange:
Debug.Print "'" & ProcName & "': No Range."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub