Remove Duplicates and move rows across sheets

[whitoulias]

Hi,

First of all let me thank in advance anyone who will take time to read and propose any solutions.

I have 4 worksheets and ideally i am looking for perhaps a command button in sheet (1) which will perform the following. This kind of check will be held daily every 30 minutes to 1 hour by different people.

(1) Incoming. This is retrieved through a web query from a trusted link from our partners representing the color of textiles and the date they will be delivered. We don't care about the batch number. Removing duplicates should be based on color and date (dd/mm/yyyy hh:mm)

Sorting.xlsx
	A	B	C
1	Colour	Date	Batch
2	Orange	06/05/2021 17:30	1
3	Orange	06/05/2021 17:30	5
4	Orange	06/05/2021 17:30	32
5	Green	06/05/2021 10:30	354
6	Green	06/05/2021 10:30	34
7	Green	06/05/2021 10:30	12
8	White	07/05/2021 19:30	7
9	White	07/05/2021 19:30	89
10	White	07/05/2021 19:30	90
11	Yellow	08/05/2021 01:00	34
12	Yellow	08/05/2021 01:00	56
13	Yellow	08/05/2021 01:00	78
14	Red	09/05/2021 22:00	6
15	Red	09/05/2021 22:00	8
16	Red	09/05/2021 22:00	4
17	Purple	10/05/2021 14:00	123
18	Purple	10/05/2021 14:00	56
19	Purple	10/05/2021 14:00	12
Incoming

(2) Checked. Once duplicates are sorted, only the colors which are included in sheet (4) should be moved here, where 2 members will perform their controls. Once the (now) time reaches the delivery time, the whole row should be moved to sheet (3)

Sorting.xlsx
	B	C	D	E	F	G
1	Colour	Date	1st Check	Initials	2nd Check	Initials
2	Green	06/05/2021 10:30	No issues	JD	No issues	NF
3	Yellow	08/05/2021 01:00	No issues	JD	No issues	NF
4	Red	09/05/2021 22:00	1 issue - Resolved	JD	No issues	NF
Checked

(3) Archived

Sorting.xlsx
	B	C	D	E	F	G
1	Colour	Date	1st Check	Initials	2nd Check	Initials
2	Green	03/05/2021 10:30	No issues	JD	No issues	NF
3	Yellow	04/05/2021 01:00	No issues	JD	No issues	NF
4	Red	05/05/2021 22:00	1 issue - Resolved	JD	No issues	NF
Archived

(4) Sample. This sheet will remain hidden and everyday a member of the staff will update the colors accordingly

Sorting.xlsx
	A
1	Colours to be Checked Today
2	Red
3	Yellow
4	Green
Sample

 

[whitoulias]

After browsing I have come up with this code which is actually working good. Could anyone help me amend the last part (For r = 1 To lr1) so instead of a simple copy paste to perform a cut+paste so empty rows can be deleted from the source sheet (rs1)?

Thank you

Sub ColorCheck()

Dim Lastrow As Long
Dim rs1 As Worksheet, rs2 As Worksheet, rs3 As Worksheet
Dim y As Date

y = Now
Set rs1 = Sheets("Incoming")
Set rs2 = Sheets("Checked")
Set rs3 = Sheets("Archived")

Application.ScreenUpdating = False

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

    ActiveSheet.Range("$A$1:$C" & 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 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)
End If

Next r

For r = 1 To lr1

If rs1.Cells(r, "A") = "Green" Or rs1.Cells(r, "A") = "Red" 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