VBA Compare 2 lists, from 2 sheets, add missing data to 1 of the lists

[THEsewingmaster]

Hello,
I'm new here! I've been scouring the web for a vba that would work for my application and found one. I adapted it to the list configuration I needed, but am having 1 problem: IT IS SLOW (I mean slooowww)! At the moment, I'm only comparing about 60 or so data entries against a list of 10.

So here is the scenario:
Comparing 2 sheets

• R_STATUS_LIST
• DATA

Searching data

• starting in C2, then C column for R_STATUS_LIST
• starting in F5, then F column for DATA

Copying the data that is found in R_STATUS_LIST but not found in DATA, then pasting it into the next available row in the F column (within the table) of DATA.

Here is the VBA I'm using:

Sub CompareLists2()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim Rng As Range, RngList As Object
    Set RngList = CreateObject("Scripting.Dictionary")
    With Sheets("DATA")
        For Each Rng In .Range("F5", .Range("F" & .Rows.Count).End(xlUp))
            If Not RngList.Exists(Rng.Value) Then
                RngList.Add Rng.Value, Nothing
            End If
        Next
    End With
    With Sheets("R_STATUS_LIST")
        For Each Rng In .Range("C2", .Range("C" & .Rows.Count).End(xlUp))
            If Not RngList.Exists(Rng.Value) Then
                Sheets("DATA").Cells(Sheets("DATA").Rows.Count, "F").End(xlUp).Offset(1, 0) = Rng
            End If
    
        Next
    End With
    RngList.RemoveAll
    Application.ScreenUpdating = True
End Sub

Any help in a better solution that accomplishes this, would be much appreciated!!

 

[kokano90]

Try to fix it like this.

Sub ABC()
Dim Dic As Object, Arr(), i&, Res(), iRow&
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("DATA")
    Arr = .Range("F5:F"& .Range("F" & .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 Sheets("R_STATUS_LIST")
    Arr = .Range("C2:C"&.Range("C" & .Rows.Count).End(xlUp).row).value
    For i = 1 To UBound(Arr)
        If Dic.exists(Arr(i, 1)) Then
            k = k + 1
            ReDim Preserve Res(1 To k)
            Res(k) = Arr(i, 1)
        End If
    Next
End With
iRow = Sheets("DATA").Range("F" & Rows.Count).End(3).Row + 1
Sheets("DATA").Range("F" & iRow).Value = Application.WorksheetFunction.Transpose(Res)
End Sub

 

[kokano90]

I don't see the data. So I don't know how to code because I can't speak English

 

[Alex Blakenburg]

I made a couple of small changes to @kokano90's code, so if the above doesn't work, try this.

Sub AddMissingItems()
    Dim Dic As Object
    Dim Arr() As Variant, outArr() As Variant
    Dim i As Long, k As Long, iRow As Long
    
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("DATA")
        Arr = .Range("F5:F" & .Range("F" & .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 Sheets("R_STATUS_LIST")
        Arr = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
        ReDim outArr(1 To UBound(Arr), 1 To 1)
        
        For i = 1 To UBound(Arr)
            If Dic.exists(Arr(i, 1)) = False Then
                k = k + 1
                outArr(k, 1) = Arr(i, 1)
            End If
        Next
    End With
    iRow = Sheets("DATA").Range("F" & Rows.Count).End(3).Row + 1
    Sheets("DATA").Range("F" & iRow).Resize(k).Value = outArr
End Sub

 

[Fluff]

@kokano90 In future please do not ask members to share files privately as it is against board rules. All communication & file sharing must be done on the board for all to see.
Thanks

 

[THEsewingmaster]

I made a couple of small changes to @kokano90's code, so if the above doesn't work, try this.

Sub AddMissingItems()
    Dim Dic As Object
    Dim Arr() As Variant, outArr() As Variant
    Dim i As Long, k As Long, iRow As Long
   
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("DATA")
        Arr = .Range("F5:F" & .Range("F" & .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 Sheets("R_STATUS_LIST")
        Arr = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
        ReDim outArr(1 To UBound(Arr), 1 To 1)
       
        For i = 1 To UBound(Arr)
            If Dic.exists(Arr(i, 1)) = False Then
                k = k + 1
                outArr(k, 1) = Arr(i, 1)
            End If
        Next
    End With
    iRow = Sheets("DATA").Range("F" & Rows.Count).End(3).Row + 1
    Sheets("DATA").Range("F" & iRow).Resize(k).Value = outArr
End Sub

Works pretty good! If I run the macro and their is no missing data, it comes up with a runtime error 1004. "Application-defined or object-defined error"
Debug shows this line of code:

    Sheets("DATA").Range("F" & iRow).Resize(k).Value = outArr

 

[Alex Blakenburg]

Works pretty good! If I run the macro and their is no missing data, it comes up with a runtime error 1004. "Application-defined or object-defined error"
Debug shows this line of code:

    Sheets("DATA").Range("F" & iRow).Resize(k).Value = outArr

Replace that line with this:-
(wrap line in an if statement)

    If k <> 0 Then
        Sheets("DATA").Range("F" & iRow).Resize(k).Value = outArr
    End If

Also ideally after the Redim outArr statement add this line:
(It works the way it is but I should have initialised k)

k = 0

 

[THEsewingmaster]

Replace that line with this:-
(wrap line in an if statement)

    If k <> 0 Then
        Sheets("DATA").Range("F" & iRow).Resize(k).Value = outArr
    End If

Also ideally after the Redim outArr statement add this line:
(It works the way it is but I should have initialised k)

k = 0

That worked great! Thank you for the help!!

I wasn't able to find the k=0 should be placed (I'm not super familiar with some of these functions, and newer to VBA in general). But it is working!