Copy rows to a new workbook based on a date range of last three months from today()

[dandee14k]

Hello me again,

I have the below code, which works perfectly to copy rows from one sheet to another based on the value of another cell.

I'm trying now to run the same sort of thing but I need to move the rows from one Workbook (main source.xlsb) to another Workbook (Archive 2023.xlsb) but I needed to be based on a date range (so basically to retain the last three months of data and move everything else to the archive my date source should be in column AB2:AB )

Just being conscious that once the main source gets to big it will slowdown the sheet.

Please let me know if this is possible and thanks again in advance.

VBA Code:
Sub MoveCellsSEA()

Dim xRg As Range

Dim xCell As Range

Dim A As Long

Dim B As Long

Dim C As Long

A = Worksheets("Files to Make Up (Sea) ").UsedRange.Rows.Count
B = Worksheets("Archive (Sea)").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archive (Sea)").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Files to Make Up (Sea) ").Range("A2:AG" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "Completed" Then
xRg(C).EntireRow.COPY
Worksheets("Archive (Sea)").Range("A" & B + 1).PasteSpecial Paste:=xlPasteValues
xRg(C).EntireRow.Delete
If CStr(xRg(C).Value) <> "" = "Completed" Then
C = C - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True

End Sub

Source Woorkbook.

Main Source.xlsb
	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG
1	File No	Origin Port	Line	Mode	USER	DOCS DL	TARIFFS	DOCS UL	C/S	BREAK DOWN	Delivery Date	Location	Reason Category (NEW)	COMMENTS	Date Completed	Target Date	Ontime/Late	Completed Month	Count	Status
2	10887	Chennai	COSCO	SEA	ED	Y	Y	Y	Y	Y	44950	MAGNA PARK	Assigned after Target Date		06/01/2023	05/01/2023	Late	Jan	1	Completed
3	10900	Chennai	COSCO	SEA	JE	Y	Y	Y	Y	Y	44953	MAGNA PARK	Missing Invoice	783789 wrong info on inv - chased again 09/01	10/01/2023	12/01/2023	On Time	Jan	1	Completed
4	10909	Nhava Sheva	MSC	SEA	ED	Y	Y	Y	Y	Y	44953	MAGNA PARK			06/01/2023	12/01/2023	On Time	Jan	1	Completed
5	10916	Mundra	MSC	SEA	ED	Y	Y	Y	Y	Y	44953	FGS			10/01/2023	12/01/2023	On Time	Jan	2	Completed
6	10916	Mundra	MSC	SEA	ED	Y	Y	Y	Y	Y	44953	FGS			10/01/2023	12/01/2023	On Time	Jan	2	Completed
7	10939	Damietta	Hapag	SEA	JE	Y	Y	Y	Y	Y	44953	MAGNA PARK	Missing Declaration	Only fed in on 12/01 and added 16/01 to adhoc - NEED EUR1 - emailed supplier	18/01/2023	12/01/2023	Late	Jan	1	Completed
8	10939	Damietta	Hapag	SEA	JE	Y	Y	Y	Y	Y	44956	MAGNA PARK	Missing Declaration	Only fed in on 12/01 and added 16/01 to adhoc - NEED EUR1 - emailed supplier	18/01/2023	12/01/2023	Late	Jan	1	Completed
9	10939	Damietta	Hapag	SEA	JE	Y	Y	Y	Y	Y	44956	MAGNA PARK	Missing Declaration	Only fed in on 12/01 and added 16/01 to adhoc - NEED EUR1 - emailed supplier	18/01/2023	12/01/2023	Late	Jan	1	Completed
10	10939	Damietta	Hapag	SEA	JE	Y	Y	Y	Y	Y	44953	MAGNA PARK	Missing Declaration	Only fed in on 12/01 and added 16/01 to adhoc - NEED EUR1 - emailed supplier	18/01/2023	12/01/2023	Late	Jan	1	Completed
11	10939	Damietta	Hapag	SEA	JE	Y	Y	Y	Y	Y	44956	MAGNA PARK	Missing Declaration	Only fed in on 12/01 and added 16/01 to adhoc - NEED EUR1 - emailed supplier	18/01/2023	12/01/2023	Late	Jan	1	Completed
12	10901	Ningbo	MSC	SEA	ED	Y	Y	Y	Y	Y	44957	MAGNA PARK			05/01/2023	15/01/2023	On Time	Jan	1	Completed
13	10901	Ningbo	MSC	SEA	ED	Y	Y	Y	Y	Y	44960	MAGNA PARK			05/01/2023	15/01/2023	On Time	Jan	1	Completed
14	10912	Xiamen	MSC	SEA	ED	Y	Y	Y	Y	Y	44957	MAGNA PARK			11/01/2023	15/01/2023	On Time	Jan	1	Completed
15	10931	Mundra	COSCO	SEA	SO	Y	Y	Y	Y	Y	44958	FGS			12/01/2023	15/01/2023	On Time	Jan	2	Completed
16	10931	Mundra	COSCO	SEA	SO	Y	Y	Y	Y	Y	44958	FGS			12/01/2023	15/01/2023	On Time	Jan	2	Completed
17	10884	Ho Chi Minh	MSC	SEA	ED	Y	Y	Y	Y	Y	44957	MAGNA PARK			03/01/2023	08/03/2023	On Time	Jan	1	Completed
18	10882	Shanghai	Yang M	SEA	SO	Y	Y	Y	Y	Y	44964	MAGNA PARK			03/01/2023	16/01/2023	On Time	Jan	1	Completed
19	10882	Shanghai	Yang M	SEA	SO	Y	Y	Y	Y	Y	44964	MAGNA PARK			03/01/2023	18/05/2023	On Time	Jan	1	Completed
Sheet1

Target Workbook.

Archive 2023.xlsb
	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG
1	File No	Origin Port	Line	Mode	USER	DOCS DL	TARIFFS	DOCS UL	C/S	BREAK DOWN	Delivery Date	Location	Reason Category (NEW)	COMMENTS	Date Completed	Target Date	Ontime/Late	Completed Month	Count	Status
2
3
4
5
6
7
8
9
10
11
12
Archive SEA

 

[MARK858]

A bit confused that your source data doesn't have any data within 3 months of today but by your description maybe try the code below.

Make sure that you have backup of the source file before testing the code as we are deleting rows.

Sub Filterit()
    Application.ScreenUpdating = False
 
    With Workbooks("main source.xlsb").Sheets("Sheet1").Range("N1:AG" & Workbooks("main source.xlsb").Sheets("Sheet1").Range("AB" & Rows.Count).End(xlUp).Row)
 
        .AutoFilter 15, "<" & DateAdd("m", -3, CDate(Date))
     
        On Error Resume Next
     
        With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            .Copy 
            Workbooks("Archive 2023.xlsb").Sheets("Archive SEA").Range("N" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
            .EntireRow.Delete
        End With
     
        On Error GoTo 0
        Workbooks("main source.xlsb").Sheets("Sheet1").ShowAllData
 
    End With
 
    Application.ScreenUpdating = True
End Sub

 

[dandee14k]

Hi,

Thanks so much for this, yeah I was very limited to the amount of data I could capture with XL2BB so couldn't add all of it.

I tested and it worked with the current details, however as I tried to extended the range to A1:AG, it stopped working,

With Workbooks("main source.xlsb").Sheets("Sheet1").Range("A1:AG" & Workbooks("main source.xlsb").Sheets("Sheet1").Range("AB" & Rows.Count).End(xlUp).Row)

I think I also needed to change the N to A here right?

.Copy Workbooks("Archive 2023.xlsb").Sheets("Archive SEA").Range("N" & Rows.Count).End(xlUp).Offset(1)

Another thing I noticed is that as I had to convert the main source to a table as I will be using this data to pull out a power query report. I think it stopped working too, I had a debug error on this.

On Error GoTo 0
        Sheets("Sheet1").ShowAllData

Is there a way to make it work so it copies from a table (main source) and paste is in another table (archive)?

I'm including links to the full file.

Archive 2023
Main source

Sorry for all the questions.

 

[MARK858]

I tested and it worked with the current details, however as I tried to extended the range to A1:AG

I don't have time to rewrite for a table tonight (it is totally different coding for how you reference the table and the ranges)

For a normal range change from A1:AG What column are the dates in now (not downloading from links as I don't need them for changing a range)?

 

[MARK858]

I had a debug error on this.

On Error GoTo 0
Sheets("Sheet1").ShowAllData

That is because you didn't see my edit where I added the workbook name

 

[dandee14k]

I don't have time to rewrite for a table tonight (it is totally different coding for how you reference the table and the ranges)

For a normal range change from A1:AG What column are the dates in now (not downloading from links as I don't need them for changing a range)?

The dates are still on AB.

No worries about the tables for tonight I know it's a bit late

e:
On Error GoTo 0
Sheets("Sheet1").ShowAllData

That is because you didn't see my edit where added the workbook name

Oh I see, got it now, thanks

 

[MARK858]

For a normal range (not a table)

Sub Filterit()
    Application.ScreenUpdating = False
 
    With Workbooks("main source.xlsb").Sheets("Sheet1").Range("A1:AG" & Workbooks("main source.xlsb").Sheets("Sheet1").Range("AB" & Rows.Count).End(xlUp).Row)
 
        .AutoFilter 28, "<" & DateAdd("m", -3, CDate(Date))
     
        On Error Resume Next
     
        With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            .Copy
            Workbooks("Archive 2023.xlsb").Sheets("Archive SEA").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
            .EntireRow.Delete
        End With
     
        On Error GoTo 0
        Workbooks("main source.xlsb").Sheets("Sheet1").ShowAllData
 
    End With
 
    Application.ScreenUpdating = True
End Sub

 

[Alex Blakenburg]

This is just @MARK858's code converted to work with tables.
As in that code it assumes both workbooks are open.
Change the 2 table names to match your table names

Sub Filterit
    Dim wbMain As Workbook
    Dim wbArch As Workbook
    Dim shtMain As Worksheet
    Dim shtArch As Worksheet
    Dim tblMain As ListObject
    Dim tblArch As ListObject
    Dim lastDataCellArch As Range
    Dim visibleMain As Range
    
    Set wbMain = ThisWorkbook
    Set wbArch = Workbooks("Archive 2023.xlsb")

    Set shtMain = wbMain.Worksheets("Main")
    Set shtArch = wbArch.Worksheets("Archive SEA")
    
    Set tblMain = shtMain.ListObjects("tblMain")            '<--- change table name to your table name
    Set tblArch = shtArch.ListObjects("Table1")             '<--- change table name to your table name
    
    Set lastDataCellArch = tblArch.ListColumns(1).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    Application.ScreenUpdating = False
    
    If tblMain.ShowAutoFilter = True Then
        tblMain.AutoFilter.ShowAllData
    End If
    
    If tblArch.ShowAutoFilter = True Then
        tblArch.AutoFilter.ShowAllData
    End If
    
    With tblMain
        .Range.AutoFilter Field:=28, Criteria1:="<" & DateAdd("m", -3, CDate(Date))
        If .Range.SpecialCells(xlCellTypeVisible).Rows.Address = .Range.Rows(1).Address Then
            MsgBox "The only visible row is the header row"
        Else
            Application.DisplayAlerts = False
            With .DataBodyRange.SpecialCells(xlCellTypeVisible)
                .Copy
                lastDataCellArch.Offset(1).PasteSpecial Paste:=xlValues
                .Rows.Delete
            End With
            Application.DisplayAlerts = True
        End If
        .AutoFilter.ShowAllData
    End With
 
    Application.ScreenUpdating = True
End Sub

 

[dandee14k]

This is just @MARK858's code converted to work with tables.
As in that code it assumes both workbooks are open.
Change the 2 table names to match your table names

Sub Filterit
    Dim wbMain As Workbook
    Dim wbArch As Workbook
    Dim shtMain As Worksheet
    Dim shtArch As Worksheet
    Dim tblMain As ListObject
    Dim tblArch As ListObject
    Dim lastDataCellArch As Range
    Dim visibleMain As Range
   
    Set wbMain = ThisWorkbook
    Set wbArch = Workbooks("Archive 2023.xlsb")

    Set shtMain = wbMain.Worksheets("Main")
    Set shtArch = wbArch.Worksheets("Archive SEA")
   
    Set tblMain = shtMain.ListObjects("tblMain")            '<--- change table name to your table name
    Set tblArch = shtArch.ListObjects("Table1")             '<--- change table name to your table name
   
    Set lastDataCellArch = tblArch.ListColumns(1).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    Application.ScreenUpdating = False
   
    If tblMain.ShowAutoFilter = True Then
        tblMain.AutoFilter.ShowAllData
    End If
   
    If tblArch.ShowAutoFilter = True Then
        tblArch.AutoFilter.ShowAllData
    End If
   
    With tblMain
        .Range.AutoFilter Field:=28, Criteria1:="<" & DateAdd("m", -3, CDate(Date))
        If .Range.SpecialCells(xlCellTypeVisible).Rows.Address = .Range.Rows(1).Address Then
            MsgBox "The only visible row is the header row"
        Else
            Application.DisplayAlerts = False
            With .DataBodyRange.SpecialCells(xlCellTypeVisible)
                .Copy
                lastDataCellArch.Offset(1).PasteSpecial Paste:=xlValues
                .Rows.Delete
            End With
            Application.DisplayAlerts = True
        End If
        .AutoFilter.ShowAllData
    End With
 
    Application.ScreenUpdating = True
End Sub

Hello,

thanks you so much for this, I do apologise for the late response I literally have not had the chance to check the code.