Compare Two Lists add new items to master list

JJCA99

Board Regular
Joined
Dec 4, 2014
Messages
50
Hello all.

Trying to find a fast way to search through two list and add any new items to the master list. Each list is on separate sheet.

Master List: Sheet "EMP ID" I have 1000+ employees with ID numbers in column "B"
New ID list: Sheet "NewBadges" has another 1k+ employees that is always growing. ID numbers are in Column "B"

So I want to compare both list and any new badges numbers from New Badges Sheet Copy the row B:E and paste it at the bottom of Master ID list B:E

Right now I have looping VBA macro that goes through NewBadges ID and deletes all matched IDnumbers then copies over any unmatched items but this takes way to long.

Any help on this would be great

here is the code I'm currently using:

Sub PRBadges()


Dim PListCount As Integer
Dim PCtr As Integer

Application.ScreenUpdating = False

PListCount = Sheets("NewBadges").Cells(Rows.Count, "B").End(xlUp).Row
For Each x In Sheets("Emp ID").Range("B2:B" & Sheets("Emp ID").Cells(Rows.Count, "B").End(xlUp).Row)

For PCtr = PListCount To 2 Step -1
If x.Value = Sheets("NewBadges").Cells(PCtr, 2).Value Then
Sheets("NewBadges").Cells(PCtr, 2).EntireRow.Delete
End If
Next PCtr
Next
Application.ScreenUpdating = True

Range("B1000").Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlUp).Offset(1, 0)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

Sheets("Emp ID").Select

Range("B3000").Select
Selection.End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

MsgBox "EmpID List Updated with Badge Numbers"

Sheets("EMP ID").Select


End Sub
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
HI JJCA99,

Interesting question. One possible way to do this would be to add a VLOOKUP in your New Badges sheet. You would look up the "New Badges" in the "EMP ID" sheet, and any #N/A lines would then need to be added to the "EMP ID" table.

You could manually write the VLOOKUP, and then have code to loop through the lines in the New Badges sheet and copy and paste only the lines with #N/A. Or, you could add the VLOOKUP formula needed with VBA.

Another idea . . . your code is working as desired, but it's just taking a long time? Try adding this at the beginning of your code along with the Application.ScreenUpdating = FALSE

Code:
Sub Give_This_A_Try()
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
End Sub

I think your code will run much faster by disabling the .Calculation. At the end of your code, just addd this:

Application.Calculation = xlCalculationAutomatic

Hope that helps.

LiveToExcel
 
Upvote 0
2 suggestions:

1st, use Application.ScreenUpdating = False in the beggining of your code (before variable declaration) and Application.ScreenUpdating = True in the end (righr before "End Sub"). This will make your screen not to update during the code, which stops the screen flickering, but also improves a lot execution time.

2nd, intead of 2 loops like you do now, try using only one. Loop through all rows in Emp Id and use .Find function in the same loop to find the duplicates, instead of looping through the other sheet.

This 2 suggestions combined will improve quite a lot you execution time
 
Upvote 0
This assumes you have headers in row 1 on both sheets.
Code:
Sub GetNewIDs()
Dim S1 As Worksheet, S2 As Worksheet, Vb As Variant, Vin As Variant, Vout As Variant
Dim n As Variant, i As Long, ct As Long, j As Long
Set S1 = Sheets("EMP ID")
Set S2 = Sheets("NewBadges")
Vin = S2.Range("B2:E" & S2.Cells(Rows.Count, "B").End(xlUp).Row).Value
ReDim Vout(1 To UBound(Vin, 1), 1 To UBound(Vin, 2))
Vb = S1.Range("B2:B" & S1.Cells(Rows.Count, "B").End(xlUp).Row).Value
For i = 1 To UBound(Vin, 1)
    On Error Resume Next
    n = Application.Match(Vin(i, 1), Vb, 0)
    On Error GoTo 0
    If IsError(n) Then
        ct = ct + 1
        For j = 1 To 4
            Vout(ct, j) = Vin(i, j)
        Next j
    End If
Next i
If ct > 0 Then
    S1.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(ct, 4).Value = Vout
Else
    MsgBox "No new IDs to add to Master List"
End If
End Sub
 
Upvote 0
Hey Thanks guys, sorry I didn't back to you sooner.

Work became really busy, but I just worked on that file again and it's running much faster.

Appreciate the help.

J.
 
Upvote 0

Forum statistics

Threads
1,223,238
Messages
6,170,939
Members
452,368
Latest member
jayp2104

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