Compare 2 Lists (Multiple Columns not consecutive)

[DagsVic]

Hi All,

I am comparing 2 lists..
List 1 is my manually entered list.
List 2 is collected using VBA.
The lists are 2 do with my movie collection, has worked very well to date but i want to make it so List 2 checks List 1 then only displays the files not listed or that do not match for whatever reason.

Below is my code i have so far that works but is very very slow to compare..

Sub ListUnknown(ByVal SourceFolderName As String)
'
Dim FSO As Object
Dim SourceFolder As Object
Dim FileItem As Object
Dim r As Long
Set wshtFiles = Sheets("File_Tasks")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
wshtFiles.Range("H7").Value = Date & " - " & Time
wshtFiles.Range("B2:D3000").ClearContents
r = wshtFiles.Range("B3000").End(xlUp).Row + 1
del = r
'Application.ScreenUpdating = False
For Each FileItem In SourceFolder.Files
  ' Display file properties
  wshtFiles.Cells(r, 2).Formula = FileItem.Name
  wshtFiles.Cells(r, 3).Value = Right(wshtFiles.Cells(r, 2), 4)
  wshtFiles.Cells(r, 2).Value = Left(wshtFiles.Cells(r, 2).Value, Len(wshtFiles.Cells(r, 2).Value) - 4)
  wshtFiles.Cells(r, 4).Value = FileItem.Size / 1024
  r = r + 1 ' next row number
Next FileItem
'
 wshtFiles.Range("B2:D2001").Sort Key1:=wshtFiles.Range("B2"), _
    order1:=xlAscending, Header:=xlNo
'Application.ScreenUpdating = False
'
' FINISHED LISTING ALL FILES
'
' COMPARE BOTH LISTS (My Current List vs Actual Files in Folder)
'
Set sht_myfiles = Sheets("MOVIES LIST")

For i = 4 To 3000
    'MsgBox ("My Files Row: " & i & " ")
    CurrentFileName = sht_myfiles.Cells(i, 4).Value & sht_myfiles.Cells(i, 5).Value & sht_myfiles.Cells(i, 11).Value
    For j = 2 To 2001
    CurrentFile = wshtFiles.Cells(j, 2).Value & wshtFiles.Cells(j, 3).Value & wshtFiles.Cells(j, 4).Value
            'MsgBox ("Current File Name: " & CurrentFileName & " " _
            '& vbCrLf & "Current File: " & CurrentFile & " ")
'
        If sht_myfiles.Cells(i, 4).Value = "" Then
            i = 3000
            j = 3000
        ElseIf sht_myfiles.Cells(i, 4).Value & sht_myfiles.Cells(i, 5).Value & sht_myfiles.Cells(i, 11).Value = wshtFiles.Cells(j, 2).Value & wshtFiles.Cells(j, 3).Value & wshtFiles.Cells(j, 4).Value Then
                wshtFiles.Cells(j, 2).Value = ""
                wshtFiles.Cells(j, 3).Value = ""
                wshtFiles.Cells(j, 4).Value = ""
                j = 2
        End If
    Next j
Next i
'Application.ScreenUpdating = True
MsgBox "Finished collecting Files"
 wshtFiles.Range("B2:D2001").Sort Key1:=wshtFiles.Range("B2"), _
    order1:=xlAscending, Header:=xlNo
'
MsgBox "FINISHED LISTING FILES"
'
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub

Once this seems to work a bit better i will then be looking into having the Lists work in a way that compares files from my Backup HDD and the NAS.
Then it will list the differences of the 2 locations and allow me to modify if needed.
Once i'm happy i click a macro that will delete old files off HDD and copy across from NAS in it's place..

Any help to speed up the Compare stuff would be great as a starter..

Oh there are approx 2000 files it goes through..
The section which lists the files works very quickly, but the compare and clear contents part takes about 15mins which is a long time..

Cheers in advance..

 

[DagsVic]

** Sorry to BUMP **

Does anyone know how to possibly speed up my code as per above post?
It runs well but very very slow..