请使用下一个更新的（您的宏）：

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

所有修改均在'________________行之间
复制同一个模块中的下一个Sub（由上面的Sub调用）：

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

请测试一下并发送一些反馈。当然，浓密的代码无法测试...

已编辑：

请尝试下一个更新的（以前的）Sub，它在上面的代码之后，移动Archive文件夹中的所有文件。现在，它应该也做了你在这个问题中要求的事情。由于它没有经过测试，你应该在测试后发送一些反馈：

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
        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并运行它。注意，现在它也会移动存档文件夹中的文件。当然，除了拼写错误的文件会被移动到它们的特殊错误文件夹中...
请在测试后发送一些反馈。