See if this code will do what you wish

Sub ColorCheck()
Dim r As Long, i As Long
Dim Lastrow, lr1 As Long, lr2 As Long
Dim rs1 As Worksheet, rs2 As Worksheet, rs3 As Worksheet
Dim y As Date
Dim dict As Object

Set dict = CreateObject("Scripting.Dictionary")
y = Now
Set rs1 = Sheets("Incoming")
Set rs2 = Sheets("Checked")
Set rs3 = Sheets("Archived")

ActiveWorkbook.RefreshAll
Application.ScreenUpdating = False

Lastrow = rs1.Range("A" & Rows.Count).End(xlUp).Row '

    rs1.Range("$A$1:$B" & Lastrow).RemoveDuplicates Columns:=1, Header:= _
        xlYes

lr1 = rs1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = rs2.Range("B" & Rows.Count).End(xlUp).Row

For i = 2 To lr2
    If Not dict.exists(rs2.Cells(i, 1).Value) Then
        dict.Add rs2.Cells(i, 1).Value, i
    End If
Next i

For r = 1 To lr2

If rs2.Cells(r, "B") < y Then
    rs2.Cells(r, "A").EntireRow.Copy Destination:=rs3.Range("A" & Rows.Count).End(xlUp).Offset(1)
    rs2.Cells(r, "A").EntireRow.Delete
    
End If

Next r

For r = 1 To lr1
        If (rs1.Cells(r, "A") = "Green" Or rs1.Cells(r, "A") = "Red") And Not dict.exists(rs1.Cells(r, "A").Value) Then
            rs1.Cells(r, "A").EntireRow.Copy Destination:=rs2.Range("A" & Rows.Count).End(xlUp).Offset(1)
        End If
Next r

Application.ScreenUpdating = True

End Sub