下面提到的代码使用moveFilesFromListPartial成功地复制了基于excel表格中提到的源名称的文件，它工作得非常好。我只需要修改一下代码。
。在excel表格中，源名写成"Robert anderson";但是，如果一个文件有不正确的拼写，如"Robertanderson";或">RoberttAnderson"进入源文件夹，这些有错误拼写的文件应该复制到另一个文件夹(例如错误文件夹)。换句话说，源文件名不在excel表格中的文件应该复制到另一个文件夹，而不是目标文件夹。这样，在一天结束的时候，我们可以确定哪些文件名有拼写错误，我们可以简单地纠正它们，而不需要检查所有的文件。
目前这些类型的文件仍然卡在源文件夹，因为不正确的文件名，他们没有得到复制，我已经添加了另一个宏，经过一些时间将文件从源文件夹移动到存档文件夹。
Sub moveFilesFromListPartial()
Const sPath As String = "E:UploadingSource"
Const dPath As String = "E:UploadingDestination"
Const fRow As Long = 2
Const Col As String = "B", colExt As String = "C"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet2
' Calculate the last row,
' i.e. the row containing the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Early Binding - needs a reference
' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Late Binding - needs no reference (no intelli-sense)
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "" Then sFolderPath = sFolderPath & ""
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "" Then dFolderPath = dFolderPath & ""
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim r As Long ' current row in worksheet column
Dim sFilePath As String
Dim sPartialFileName As String
Dim sFileName As String
Dim dFilePath As String
Dim sYesCount As Long ' source file moved
Dim sNoCount As Long ' source file not found
Dim dYesCount As Long ' source file exists in destination folder
Dim BlanksCount As Long ' blank cell
Dim sExt As String 'extension (dot inclusive)
For r = fRow To lRow
sPartialFileName = CStr(ws.Cells(r, Col).Value)
sExt = CStr(ws.Cells(r, colExt).Value)
If Len(sPartialFileName) > 3 Then ' the cell is not blank
' 'Begins with' sPartialFileName
sFileName = Dir(sFolderPath & sPartialFileName & "*" & sExt)
Do While sFileName <> ""
If Len(sFileName) > 3 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the source file...
fso.CopyFile sFilePath, dFilePath ' ... doesn't exist...
sYesCount = sYesCount + 1 ' ... in the destination
Else ' the source file exists in the destination folder
dYesCount = dYesCount + 1
End If
Else ' the source file doesn't exist
sNoCount = sNoCount + 1
End If
sFileName = Dir
Loop
Else ' the cell is blank
BlanksCount = BlanksCount + 1
End If
Next r
End Sub
复制文件到目标文件夹后运行的另一个代码，它将文件从源文件夹移动到存档文件夹。
Sub moveAllFilesInDateFolderIfNotExist()
Dim DateFold As String, fileName As String, objFSO As Object
Const sFolderPath As String = "E:UploadingSource"
Const dFolderPath As String = "E:UploadingArchive"
DateFold = dFolderPath & "" & Format(Date, "ddmmyyyy") ' create the folder
if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "*.*")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do While fileName <> ""
If Not objFSO.FileExists(DateFold & "" & fileName) Then
Name sFolderPath & "" & fileName As DateFold & "" & fileName
Else
Kill DateFold & "" & fileName
Name sFolderPath & "" & fileName As DateFold & "" & fileName
End If
fileName = Dir
Loop
End Sub
请使用下次更新的(宏):
Sub AddMissingItems()
Dim Dic As Object, arr() As Variant, outArr() As Variant
Dim i As Long, k As Long, iRow As Long, c As Long
Dim r As Long, j As Long
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("Sheet1")
arr = .Range("A1:A" & .Range("A" & .rows.count).End(xlUp).row).Value
For i = 1 To UBound(arr, 1)
If Dic.Exists(arr(i, 1)) = False Then
Dic.Add (arr(i, 1)), ""
End If
Next
End With
With Workbooks("ExtractFile.xlsx").Worksheets("Sheet1")
c = .cells(1, Columns.count).End(xlToLeft).column
r = .Range("A" & .rows.count).End(xlUp).row 'calculate the last row in A:A, too
arr = .Range("A1", .cells(r, c)).Value 'place in the array all existing columns
ReDim outArr(1 To UBound(arr), 1 To c) 'extend the redimmed array to all columns
For i = 1 To UBound(arr)
If Dic.Exists(arr(i, 1)) = False Then
k = k + 1
For j = 1 To c 'iterate between all array columns:
outArr(k, j) = arr(i, j) 'place the value from each column
Next j
End If
Next
End With
iRow = Sheets("Sheet1").Range("A" & rows.count).End(3).row + 1
If k <> 0 Then
Sheets("Sheet1").Range("A" & iRow).Resize(k, UBound(arr, 2)).Value = outArr 'resize by columns, too
k = 0
End If
End Sub
Sub moveFilesFromListPartial()
Const sPath As String = "E:UploadingSource", dPath As String = "E:UploadingDestination"
Const Col As String = "B", colExt As String = "C"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet2
' Calculate the last row,
Dim lRow As Long: lRow = ws.cells(ws.rows.count, Col).End(xlUp).row
' Validate the last row.
If lRow < 2 Then MsgBox "No data in column range.", vbCritical: Exit Sub
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "" Then sFolderPath = sFolderPath & ""
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath & "' doesn't exist.", vbCritical: Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "" Then dFolderPath = dFolderPath & ""
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath & "' doesn't exist.", vbCritical: Exit Sub
End If
Dim r As Long, sFilePath As String, sPartialFileName As String, sFileName As String
Dim dFilePath As String, sExt As String 'extension (dot inclusive)
'_________________________________________________________________________________
Dim arrC, k As Long 'an array to keep the copied fileNames and a variable to keep
'the next array element to be loaded
Dim objFolder As Object: Set objFolder = fso.GetFolder(sPath)
ReDim arrC(objFolder.files.count) 'redim the array at the number of total files
'_________________________________________________________________________________
For r = 2 To lRow
sPartialFileName = CStr(ws.cells(r, Col).Value)
sExt = CStr(ws.cells(r, colExt).Value)
If Len(sPartialFileName) > 3 Then ' the cell is not blank
sFileName = Dir(sFolderPath & sPartialFileName & "*" & sExt)
Do While sFileName <> ""
If Len(sFileName) > 3 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the destination file...
fso.CopyFile sFilePath, dFilePath ' ... if doesn't exist...
'________________________________________________________________________
arrC(k) = sFileName: k = k + 1 'each copied file name is loaded in the array
'________________________________________________________________________
Else
'______________________________________________________________________
arrC(k) = sFileName: k = k + 1 'each copied file name is loaded in the array
'________________________________________________________________________
End If
End If
sFileName = Dir
Loop
End If
Next r
'__________________________________________________________________________________
If k > 0 Then ReDim Preserve arrC(k - 1) 'keep in the array only loaded elements
moveReminedFiles sPath, arrC
'_________________________________________________________________________________
End Sub
之间的所有修改 '_______________ 行
复制下一个Sub，它被上面的调用，在同一个模块中:
Sub moveReminedFiles(sFolder As String, arr)
Dim fileName As String, mtch
Const destFolder As String = "E:UploadingError Files" 'use here your folder where errored files to be moved
If Right(sFolder, 1) <> "" Then sFolder = sFolder & ""
fileName = Dir(sFolder & "*.*")
Do While fileName <> ""
mtch = Application.match(fileName, arr, 0) 'if the file name does not exist in the array:
If IsError(mtch) Then Name sFolder & fileName As destFolder & fileName 'move it
fileName = Dir
Loop
End Sub
请测试它并发送一些反馈。当然，这些复杂的代码是无法测试的…
:
请尝试下一个更新的(以前的)Sub，它出现在上述代码之后，移动Archive文件夹中的所有文件。现在，它也应该满足你在这个问题中所要求的。因为它没有经过测试，你应该在测试后发送一些反馈:
Sub moveAllFilesInDateFolderIfNotExist(sFolderPath As String, arr)
Dim DateFold As String, fileName As String, objFSO As Object, mtch
Const dFolderPath As String = "E:UploadingArchive"
Const errFolder As String = "E:UploadingError Files"
If Right(sFolderPath, 1) <> "" Then sFolderPath = sFolderPath & ""
DateFold = dFolderPath & "" & Format(Date, "ddmmyyyy") & "" ' create the cur date folder name
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold 'create the necessary folder if it does not exist
fileName = Dir(sFolderPath & "*.*")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do While fileName <> ""
mtch = Application.match(fileName, arr, 0)
If IsError(mtch) Then 'if the file name does not exist in the array:
If objFSO.FileExists(errFolder & "" & fileName) Then
Kill errFolder & fileName
End If
Name sFolderPath & fileName As errFolder & fileName 'move it
Else
If Not objFSO.FileExists(DateFold & "" & fileName) Then
Name sFolderPath & fileName As DateFold & fileName
Else
Kill DateFold & fileName
Name sFolderPath & fileName As DateFold & fileName
End If
End If
fileName = Dir
Loop
End Sub
您只需要将moveReminedFiles sPath, arrC更改为moveAllFilesInDateFolderIfNotExist sPath, arrC并运行它。注意，现在它还将移动存档文件夹中的文件。当然，除了拼写错误的将被移动到他们的特殊的错误文件夹…
请在测试后发送一些反馈。