Files whose source is not in excel sheet should copy to another folder

Question

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

Answer 1

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:
        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

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.