Copying only new entries from a sheet that meet a criteria and adding at the end of a column in another sheet - excel

Question

I've been trying to work through a problem for a sheet I'm working on but my limited vba knowledge has got me stuck.
What I currently have is code that copies over a reference number (column A) for a record to a new sheet if it has the value "CHK" in Column Y. This code is shown below.
The issue i'm having is trying to add some code that means when I run the macro only new entries that match the criteria will be copied over. At the moment when I run the macro it duplicates the entries that have already been copied (i.e. I run the macro once and get 1,2,3 I then run it again, adding another cell, and get 1,2,3,1,2,3,4.
I've been trying to come up with ideas and thought about using "If" to compare the final reference number in the sheet i copy to and the register sheet. And then setting up a similar process that would only copy values that were larger than the final reference number in the sheet i copy to. This would require me to set up the same process as below but limited to only values greater than the final value in the sheet i'm copying to.
This would require two macros i think, one to populate the list the first time (code that is below) and then one to run an update as discussed.
My question was will this process work or are there better ways that i am missing to achieve what I need to achieve.
Thanks all.
Sub Copy_detailed_WithNum_V4_Test()
'Create and set worksheet variables
Dim ws1 As Worksheet: Set ws1 = Sheets("Detailed Register-All")
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
'Create search range, cel and lastrow variable
Dim SrchRng As Range, cel As Range, Lastrow As Long
'Set the range to search as column Y in the detailed register (Y2 to last used cell in Y)
Set SrchRng = ws1.Range("Y2:Y" & ws1.Range("Y" & ws1.Rows.Count).End(xlUp).Row)
'Stop screen updating with each action
Application.ScreenUpdating = False
For Each cel In SrchRng
'Check if the VIPP Flag for the entry is CHK
If InStr(1, cel.Text, "CHK") Then
'If the entry is CHK, set the lastrow variable as first empty cell in row a of the VIPP Register
Lastrow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Row
'Set the value of cells in Column A in VIPP Register to be equal to record number values for those entries that require a VIPP CHK
ws2.Cells(Lastrow, 1).Value = cel.Offset(0, -24).Value
End If
'Repeat for next cell in the search range
Next cel
Application.ScreenUpdating = True
End Sub

Answer 1

I believe this will do the trick.
You can run the macros seperately or add Call RemoveDuplicates before ending your first sub.
Sub RemoveDuplicates()
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
Dim Unique As Range: Set Unique = ws2.Range("A2:A" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row)
Dim MyCell As Range, DeleteMe As Range
For Each MyCell In Unique
If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), MyCell) > 1 Then
If DeleteMe Is Nothing Then
Set DeleteMe = MyCell
Else
Set DeleteMe = Union(DeleteMe, MyCell)
End If
End If
Next MyCell
If Not DeleteMe Is Nothing Then DeleteMe.EntireRow.Delete
End Sub
This should check to see if your value exists before even pasting which means this one sub should be sufficient.
Sub Copy_detailed_WithNum_V4_Test()
Dim ws1 As Worksheet: Set ws1 = Sheets("Detailed Register-All")
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
Dim SrchRng As Range, cel As Range, Lastrow As Long
Set SrchRng = ws1.Range("Y2:Y" & ws1.Range("Y" & ws1.Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
For Each cel In SrchRng
If InStr(1, cel.Text, "CHK") Then
If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), cel.Offset(0, -24)) = 0 Then
Lastrow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Row
ws2.Cells(Lastrow, 1).Value = cel.Offset(0, -24).Value
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub