Copy/paste rows based on today's date

[SushiJuice]

Hello,

Long time fan of the YouTube channel, but first time posting here. I've implemented a lot of ideas from info gained from the shows, but I'm really green when it comes to VBA.

I'm trying to copy rows from Sheet 1 to Sheet 2 as an archive system so Sheet 2 would continually add more data as time goes on; essentially copying any rows with dates on or before today and pasting them into Sheet 2

The date column is H:H and pasting entire row to Sheet 2.

Please help

 

[RasGhul]

Hi Sushi,

This macro is applied to the workbook close event, so the records on or before today from column H will be cleared then copied over when you close your workbook.

1. Navigate to Developer tab/Visual Basic/right click this Workbook in the left project view/View code
2. Change the Top Left drop down to Workbook and the Top right drop down to Before Close
3. Enter the following vba
4. Add the Thaw Date criteria in I1 & I2 like in my sample

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim rg As Range
Set rg = ThisWorkbook.Worksheets("Sheet2").Range("A1").CurrentRegion

rg.Offset(1).ClearContents

Dim rgdata As Range, rgcriteria As Range, rgOutput As Range

Set rgdata = ThisWorkbook.Worksheets("Sheet1").Range("A4").CurrentRegion
    Set rgcriteria = ThisWorkbook.Worksheets("Sheet1").Range("I1").CurrentRegion
Set rgOutput = ThisWorkbook.Worksheets("Sheet2").Range("A1").CurrentRegion

rgdata.AdvancedFilter xlFilterCopy, rgcriteria, rgOutput


End Sub

Copy - paste rows based on today's date SushiJuice.xlsm
	A	B	C	D	E	F	G	H	I
1	Cut date	Item	Salerep	Thaw Weight	Child	Child Weight	Thaw Date		Thaw Date
2	21/01/2022	Halibut 40/u p	Adam M (388)	35			21/01/2022		<=44582
3	23/01/2022	Halibut 40/u p	Ellen Jones (323)	300			23/01/2022
4	24/01/2022	Halibut U/20	Adam M (388)	20			22/01/2022
5	24/01/2022	Halibut 40/u p	Adam M (388)	70			24/01/2022
6	24/01/2022	Sablefish 7/u p	Adam M (388)	10			23/01/2022
7	22/01/2022	Halibut U/20	Mike M (321)	450			22/01/2022
8	25/01/2022	Halibut 40/u p	Ellen Jones (323)	300			25/01/2022
9	24/01/2022	C/R Sockeye	Ellen Jones (323)	50			24/01/2022
10	27/01/2022	Halibut 40/u p	Ellen Jones (323)	300			27/01/2022
11	19/01/2022	Halibut 40/u p	Adam M (388)	35			19/01/2022
12	23/01/2022	Halibut 40/u p	Ellen Jones (323)	300			17/01/2022
13	24/01/2022	Halibut U/20	Adam M (388)	20			15/01/2022
14	24/01/2022	Halibut 40/u p	Adam M (388)	70			13/01/2022
15	24/01/2022	Sablefish 7/u p	Adam M (388)	10			11/01/2022
16	22/01/2022	Halibut U/20	Mike M (321)	450			9/01/2022
17	25/01/2022	Halibut 40/u p	Ellen Jones (323)	300			7/01/2022
18	24/01/2022	C/R Sockeye	Ellen Jones (323)	50			5/01/2022
19	27/01/2022	Halibut 40/u p	Ellen Jones (323)	300			3/01/2022
Sheet1

Cell Formulas
Range	Formula
I2	I2	="<="&TODAY()

Copy - paste rows based on today's date SushiJuice.xlsm
	A	B	C	D	E	F	G
1	Cut date	Item	Salerep	Thaw Weight	Child	Child Weight	Thaw Date
2	21/01/2022	Halibut 40/u p	Adam M (388)	35			21/01/2022
3	19/01/2022	Halibut 40/u p	Adam M (388)	35			19/01/2022
4	23/01/2022	Halibut 40/u p	Ellen Jones (323)	300			17/01/2022
5	24/01/2022	Halibut U/20	Adam M (388)	20			15/01/2022
6	24/01/2022	Halibut 40/u p	Adam M (388)	70			13/01/2022
7	24/01/2022	Sablefish 7/u p	Adam M (388)	10			11/01/2022
8	22/01/2022	Halibut U/20	Mike M (321)	450			9/01/2022
9	25/01/2022	Halibut 40/u p	Ellen Jones (323)	300			7/01/2022
10	24/01/2022	C/R Sockeye	Ellen Jones (323)	50			5/01/2022
11	27/01/2022	Halibut 40/u p	Ellen Jones (323)	300			3/01/2022
Sheet2

 

[SushiJuice]

Thanks so much. This is a shared workbook across multiple departments so the act of closing the file would actually work against the intended expectations. Any chance we can get it simply to where I can assign it to a button?

 

[RasGhul]

Thats ok, insert a suitable shape right click on the new shape and click assign macro. Paste the code from above.

 

[SushiJuice]

Thats ok, insert a suitable shape right click on the new shape and click assign macro. Paste the code from above.

Will it still auto-archive when the file closes?

 

[RasGhul]

Will it still auto-archive when the file closes?

You could have both running, if preferred. The macro can be run from a shape as a button or an event

I prefer to use the workbook close event just in case someone forgets to press the button.

This is what the code should look like when applied to a shape;

Sub RectangleRoundedCorners1_Click()

Dim rg As Range
Set rg = ThisWorkbook.Worksheets("Sheet2").Range("A1").CurrentRegion

rg.Offset(1).ClearContents

Dim rgdata As Range, rgcriteria As Range, rgOutput As Range

Set rgdata = ThisWorkbook.Worksheets("Sheet1").Range("A4").CurrentRegion
    Set rgcriteria = ThisWorkbook.Worksheets("Sheet1").Range("I1").CurrentRegion
Set rgOutput = ThisWorkbook.Worksheets("Sheet2").Range("A1").CurrentRegion

rgdata.AdvancedFilter xlFilterCopy, rgcriteria, rgOutput

End Sub

 

[SushiJuice]

You could have both running, if preferred. The macro can be run from a shape as a button or an event

I prefer to use the workbook close event just in case someone forgets to press the button.

This is what the code should look like when applied to a shape;

Sub RectangleRoundedCorners1_Click()

Dim rg As Range
Set rg = ThisWorkbook.Worksheets("Sheet2").Range("A1").CurrentRegion

rg.Offset(1).ClearContents

Dim rgdata As Range, rgcriteria As Range, rgOutput As Range

Set rgdata = ThisWorkbook.Worksheets("Sheet1").Range("A4").CurrentRegion
    Set rgcriteria = ThisWorkbook.Worksheets("Sheet1").Range("I1").CurrentRegion
Set rgOutput = ThisWorkbook.Worksheets("Sheet2").Range("A1").CurrentRegion

rgdata.AdvancedFilter xlFilterCopy, rgcriteria, rgOutput

End Sub

Getting an error

I have that formula in cell I1 (should it be in I2?). I only changed the names of the sheet. Am I missing something?

 

[RasGhul]

Getting an error

View attachment 56089

View attachment 56090

I have that formula in cell I1 (should it be in I2?). I only changed the names of the sheet. Am I missing something?

Yes you need to have Thaw date in I1 and the <=TODAY() formula in I2 exactly like in my sample above.
Then excel knows the advanced filter criteria is for the Thaw dates column.

 

[SushiJuice]

OK, I've made this change and I still get the same error

 

[RasGhul]

It looks like the top row with Optional is causing the error, when I insert a blank row A2:G2 so there is a gap between Optional and your table the macro works for me.