macro to check for duplicates and copy data if no duplicate found

[guardian4119]

Hi,

I am trying to write a macro that activates when sheet2 is clicked on. what im tying to get the macro to do is checks all the entries (which are text, not values) in sheet 1, column B and looks for duplicates in sheet2 column C. If a duplicate is not found, it copies sheet 1 columns B,D,E to C,D,E of the next empty row of sheet2. Also, if a cell is found blank in sheet1, to just skip it. Any help would be appreciated. Thank you.

 

[RickXL]

Hi,

Try this:

Private Sub Worksheet_Activate()

    Dim i As Long, lr As Long, dic As Object, arr1, arr2
    Set dic = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Worksheets("Sheet1")
        arr1 = .Range("B1:E" & .Cells(.Rows.Count, "B").End(xlUp).Row)
    End With
    
    lr = Cells(Rows.Count, "C").End(xlUp).Row
    arr2 = Range("C1:C" & lr)

    For i = 1 To UBound(arr2)
        dic(arr2(i, 1)) = vbNullString
    Next
    
    Application.ScreenUpdating = False
    For i = 1 To UBound(arr1)
        If Not dic.exists(arr1(i, 1)) Then
            lr = lr + 1
            Cells(lr, "C").Value = arr1(i, 1)
            Cells(lr, "D").Value = arr1(i, 3)
            Cells(lr, "E").Value = arr1(i, 4)
        End If
    Next
    Application.ScreenUpdating = True
     
End Sub

It copies the data from Sheet1 into an array.
It also copies column C from Sheet2 into an array.
The Sheet2 data is inserted into a Dictionary object. Dictionaries are direct access objects that will maintain a list of unique keys.
The Sheet1 array is now looped round and compared with the Dictionary.
If no match is found then the data is added to Sheet2.

The macro needs to go into the code module associated with Sheet2. Then when Sheet2 is activated it will run automatically and append any updates from Sheet1.

 

[Trebor76]

For reference this has been cross-posted here.