Below mentioned code successfully copies the file based on source names mentioned in excel sheet using moveFilesFromListPartial, it works perfectly well. i just need one change in the code.
e.g. in excel sheet a source name is written as "Robert Anderson" However if a file with incorrect spelling like "Robert Andersonn" or "Robertt Anderson" comes into source folder, these file with incorrect spelling should get copy in another folder (e.g. Error Folder). In other words files whose exact source name is not in excel sheet should get copy to another folder rather than the destination folder. This way at the end of day we can identify which file names have spelling mistakes and we can simply correct them without reviewing all the files.
currently these kind of files remain stuck in source folder and because of incorrect file name they do not get copy, and i have added another macro which after some times moved the file from Source folder to Archive folder.
Sub moveFilesFromListPartial()
Const sPath As String = "E:\Uploading\Source"
Const dPath As String = "E:\Uploading\Destination"
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
Another Code which I run after copying the file to Destination folder which moves the files from Source to Archive folder.
Sub moveAllFilesInDateFolderIfNotExist()
Dim DateFold As String, fileName As String, objFSO As Object
Const sFolderPath As String = "E:\Uploading\Source"
Const dFolderPath As String = "E:\Uploading\Archive"
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
CodePudding user response：
Please, use the next updated (your macro):
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:\Uploading\Source", dPath As String = "E:\Uploading\Destination"
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
All modifications are between '_______________ lines
Copy the next Sub, which is called by the above one, in the same module:
Sub moveReminedFiles(sFolder As String, arr)
Dim fileName As String, mtch
Const destFolder As String = "E:\Uploading\Error 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
Please, test it and send some feedback. Of course, the bushy code could not be tested...
Edited:
Please, try the next updated (former) Sub which comes after the above code, moving all files in the Archive folder. Now, it should also do what you required in this question. Since it is not tested, you should send some feedback after testing it:
Sub moveAllFilesInDateFolderIfNotExist(sFolderPath As String, arr)
Dim DateFold As String, fileName As String, objFSO As Object, mtch
Const dFolderPath As String = "E:\Uploading\Archive\"
Const errFolder As String = "E:\Uploading\Error 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:
Name sFolderPath & fileName As errFolder & fileName 'move it
Else
If Not objFSO.FileExists(DateFold & "\" & fileName) Then
Name sFolderPath & fileName As DateFold & fileName
End If
End If
fileName = Dir
Loop
End Sub
You only have to change moveReminedFiles sPath, arrC with moveAllFilesInDateFolderIfNotExist sPath, arrC and run it. Take care that now it will also move the files in the archive folder. Of course, except the wrong spelled ones which will be moved in their special Error folder...
Please, send some feedback after testing it.