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

THEsewingmaster

New Member
Joined
Mar 14, 2022
Messages
9
Office Version
  1. 365
Platform
  1. Windows
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:

VBA Code:
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!!
 
Try to fix it like this.
VBA Code:
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
 
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
I don't see the data. So I don't know how to code because I can't speak English
 
Upvote 0
I made a couple of small changes to @kokano90's code, so if the above doesn't work, try this.

VBA Code:
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
 
Upvote 0
@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
 
Upvote 0
I made a couple of small changes to @kokano90's code, so if the above doesn't work, try this.

VBA Code:
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:
VBA Code:
    Sheets("DATA").Range("F" & iRow).Resize(k).Value = outArr
 
Upvote 0
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:
VBA Code:
    Sheets("DATA").Range("F" & iRow).Resize(k).Value = outArr

Replace that line with this:-
(wrap line in an if statement)
VBA Code:
    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)
VBA Code:
k = 0
 
Upvote 0
Solution
Replace that line with this:-
(wrap line in an if statement)
VBA Code:
    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)
VBA Code:
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!
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top