在excel中复制、重命名和验证多个文件和路径是否成功
在过去的5天里，我一直在这里和网络上四处寻找适合多个文件的东西。许多深夜/清晨拼凑/编码以获得结果都没有成功。提前谢谢 以下代码来自奥斯卡编写的get-digital-help.com/copyrame-a-file-excel-vba 它适用于1个文件，我有8000个文件要在一个深文件夹结构中执行，所以我真的希望每一行查看源路径、源文件名、目标路径和目标文件： 对于每行：在excel中复制、重命名和验证多个文件和路径是否成功,excel,vba,validation,copy,rename,Excel,Vba,Validation,Copy,Rename,在过去的5天里，我一直在这里和网络上四处寻找适合多个文件的东西。许多深夜/清晨拼凑/编码以获得结果都没有成功。提前谢谢 以下代码来自奥斯卡编写的get-digital-help.com/copyrame-a-file-excel-vba 它适用于1个文件，我有8000个文件要在一个深文件夹结构中执行，所以我真的希望每一行查看源路径、源文件名、目标路径和目标文件： 对于每行： 列A列出源路径 列B列出了源文件名 列C列出目标路径 列D列出了新的文件名 列E写“成功”或“失败”验证 如果目标中
- 列A列出源路径
- 列B列出了源文件名
- 列C列出目标路径
- 列D列出了新的文件名
- 如果目标中已存在文件名，则“失败”
- 如果源文件不存在，则“失败”
子副本重命名文件（）
'维度变量和声明数据类型
Dim src为字符串，dst为字符串，fl为字符串
作为字符串的Dim rfl
'将单元格A2中指定的源目录保存到变量src
src=范围（“A2”）
'将单元格C2中指定的目标目录保存到变量dst
dst=范围（“C2”）
'将单元格B2中指定的文件名保存到变量fl
fl=范围（“B2”）
'将单元格D2中指定的新文件名保存到变量rfl
rfl=范围（“D2”）
'启用错误处理
出错时继续下一步
'将基于变量src和fl的文件复制到基于变量dst的目标文件夹，并根据rfl中的值命名文件
文件拷贝src&“\”&fl，dst&“\”&rfl
'检查是否发生了错误
如果错误号为0，则
'使用消息框显示错误
MsgBox“复制错误：&src&“\”&rfl
如果结束
'禁用错误处理
错误转到0
端接头
- 此解决方案包括三个步骤。您只运行第一个：
。其他两个，copyramenefile
和getOffsetColumn
将在必要时由第一个调用writeOffsetRange - 最好使用新工作簿对其进行测试。插入模块并将代码复制到其中。现在打开原始工作簿并将某些值复制到新工作簿的
。由于代码是为Sheet1
（包含此代码的工作簿）编写的，因此原始工作簿将是安全的（不会写入）此工作簿 - 首先调整常量部分中的值（标题为
和工作表
）。然后测试空工作表。然后使用列其他
中的一个文件夹进行测试，然后使用更多文件夹进行测试，然后缓慢地继续使用其他列进行测试。应抑制可能的错误，并且其消息（说明）应显示在A
的VBE
窗口（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) = filMsg(0)
Target(1)(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) = filMsg(0)
Target(1)(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) = filMsg(0)
Target(1)(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
您可以使用
Dir（fullPathHere）文件夹，文件夹，文件，文件“A”，“B”，“C”，“D”代替“A”，“C”，“B”，“D”
，效果很好。不能发布文件或屏幕转储（对本论坛来说太新）A=C:\temp3\Source，B=C:\temp3\Destination，C=1.txt，D=10.txt结果通过，E Copy=Success&F Source Exists=TRUE。再次运行测试，一切正常-Copy=Fail，SourceFile=duplicate它在下一行失败，其中：A=C:\temp3\Source\Original1，B=C:\temp3\Destination\01，C=3.txt，D=12.txt-Copy=Fail&Source=FAl这意味着文件夹C:\temp3\Source\Original1
不存在，因为Source=FALSE
。如果文件夹存在且12.txt
存在，则它将是Source=replicate
。
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) = filMsg(0)
Target(1)(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) = filMsg(0)
Target(1)(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) = filMsg(0)
Target(1)(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
' e.g. "C:\Test" is an existing folder, "C:\Test\Test1" is not.
' When you want to create the folder "C:\Test\Test1\Test2", 'MkDir' will return
' "Run-time error '76': Path Not found", because "C:\Test\Test1" does not exist.
' The 'createFolders' function remedies this by creating as many folders
' as needed. In the previous example it first creates "C:\Test\Test1" and
' only then creates "C:\Test\Test1\Test2" in it.
' The function returns 'True' if the folder previously existed or now exists.
' The function returns 'False' if 'PathString' is invalid.
Function createFolders(PathString As String) As Boolean
' Initialize error handling.
Const ProcName As String = "createFolders"
On Error GoTo clearError ' Turn on error trapping.
' Split Path String ('PathString') by System Path Separator ('Delimiter')
' into 1D zero-based Folders Array 'Folders()'.
Dim Delimiter As String
Delimiter = Application.PathSeparator
Dim Folders() As String
Folders = Split(PathString, Delimiter)
' Define Last Subscript ('LastSS') to be considered, because Path String
' could be ending with a System Path Separator.
Dim LastSS As Long
LastSS = UBound(Folders)
If Folders(LastSS) = "" Then
LastSS = LastSS - 1
End If
' Using Folders Array, write paths to Paths Array ('Paths()').
Dim Paths() As String
ReDim Paths(0 To LastSS)
Paths(0) = Folders(0)
Dim j As Long
If LastSS > 0 Then
For j = 1 To LastSS
Paths(j) = Paths(j - 1) & Delimiter & Folders(j)
Next j
End If
' Create each folder if it does not exist.
For j = 0 To LastSS
If Dir(Paths(j), vbDirectory) = "" Then
MkDir Paths(j)
End If
Next j
' Write result.
createFolders = True
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Function
Sub testCreateFolders()
Const PathString As String = "C:\Test\Test1\Test2"
Dim Result As Boolean
Result = createFolders(PathString)
If Result Then
MsgBox "If the path previously didn't exist, now it certainly does."
Else
MsgBox "The supplied path is invalid."
End If
End Sub
Sub testMkDir()
Const PathString As String = "C:\Test\Test1\Test2"
MkDir PathString
End Sub