VBA Code Change

Rob_010101

Rob_010101

Board Regular
Joined
Jul 24, 2017
Messages
198
Office Version
  1. 365
Platform
  1. Windows
Hello,

@Petertenthije kindly provided the below code for my absence tracker on 13 August 2022.

On the "current 12 months" tab, is held all absences within the current 12 month rolling period. The code will then activate upon opening the workbook and move any rows with an absence start date of less than 12 months from today to the "previous 12 months" tab. Then, on the "previous 12 months" tab, any rows with an absence start date of less than 24 months in the current 24-month rolling period are deleted.
  • Current 12 months Tab - All absences in the latest 12 month rolling period
  • Previous 12 months Tab - All absences in the previous 12 month rolling period
I now need this to change, so that it looks at:
  • Current 6 months Tab - All absence in the last 6 month rolling period from the current day (based on absence start date)
  • Previous 6 months Tab - All absence from 6 months to 12 months from the current day (based on absence start date)
  • Previous 12 months Tab - All absence between 12 months and 24 months (based on absence start date)
Basically, when the workbook is opened, the code should move the rows between each tab, based on the absence start date and finally delete the row from "previous 12 months" once the absence start date is more than 24 months old from today.

The names and order of the columns will remain the same.

Hope this makes sense. @petertenthije original code is below:

VBA Code: 
Sub Workbook_Open()



' Set variables
    ' Move date
        Dim ToBeMovedDate As Long
        ToBeMovedDate = DateSerial(Year(Date) - 1, Month(Date), Day(Date))
    ' Delete date
        Dim ToBeDeletedDate As Long
        ToBeDeletedDate = DateSerial(Year(Date) - 2, Month(Date), Day(Date))
    ' Last row with data, current 12 months
        Dim LastRowCurrent12Months As String
        LastRowCurrent12Months = Sheets("Current 12 months").Cells(Sheets("Current 12 months").Rows.Count, "A").End(xlUp).Row
    ' Last row with data, previous 12 months
        Dim LastRowPrevious12Months As String
        LastRowPrevious12Months = Sheets("Previous 12 months").Cells(Sheets("Previous 12 months").Rows.Count, "A").End(xlUp).Row



' Remove existing filters , if applicable
    On Error Resume Next
        Sheets("Current 12 months").ShowAllData
        Sheets("Previous 12 months").ShowAllData
    On Error GoTo 0



'   o-------------------------------------------------------------o
'   |   MOVE LINES FROM CURRENT 12 MONTHS TO PREVIOUS 12 MONTHS   |
'   o-------------------------------------------------------------o

    ' Verify there are rows to be moved
        NumberOfRowsOnCurrent = WorksheetFunction.CountIfs(Sheets("Current 12 months").Range("J:J"), "<=" & ToBeMovedDate)

If NumberOfRowsOnCurrent > 0 Then
    ' Filter dates to be moved
        Sheets("Current 12 months").Range("A:N").AutoFilter Field:=10, Criteria1:="<=" & ToBeMovedDate
    ' Copy data to be moved to previous 12 months
        Sheets("Current 12 months").Select
        Sheets("Current 12 months").Range("A2:N" & LastRowCurrent12Months).Select
        Selection.Offset(0, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy
    ' Paste data into previous 12 months worksheet
        Sheets("Previous 12 months").Select
        Sheets("Previous 12 months").Range("A" & LastRowPrevious12Months + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ' Remove copied data from current 12 months
        Sheets("Current 12 months").Select
        Sheets("Current 12 months").Range("A2:N" & LastRowCurrent12Months).Select
        Selection.Offset(0, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    ' Remove filter
        Sheets("Current 12 months").ShowAllData
End If



'   o-------------------------------------------------------------o
'   |            REMOVE LINES FROM PREVIOUS 12 MONTHS             |
'   o-------------------------------------------------------------o

    ' Verify there are rows to be removed
        NumberOfRowsOnPrevious = WorksheetFunction.CountIfs(Sheets("Previous 12 months").Range("J:J"), "<=" & ToBeDeletedDate)

If NumberOfRowsOnPrevious > 0 Then
    ' Filter dates to be deleted
        Sheets("Previous 12 months").Select
        Sheets("Previous 12 months").Range("A:N").AutoFilter Field:=10, Criteria1:="<=" & ToBeDeletedDate
    ' Select rows to be removed
        Sheets("Previous 12 months").Range("A2:N" & LastRowPrevious12Months).Select
    ' Delete rows
        Selection.Offset(0, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    ' Remove filter
        Sheets("PRevious 12 months").ShowAllData
End If



End Sub
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Sort by date Sort by votes
When you say previous 6 months, what exactly do you mean?

OK, today is October 21st.
Do you then mean april 21st.
Do you mean april 1st?
What if it’s september 30th, there is no february 30th.
Or today’s date minus 180[ish] days?
 
Upvote 0
petertenthije said:
When you say previous 6 months, what exactly do you mean?

OK, today is October 21st.
Do you then mean april 21st.
Do you mean april 1st?
What if it’s september 30th, there is no february 30th.
Or today’s date minus 180[ish] days?
Click to expand...
Hi There,

Thanks very much for getting back to me.

So it would be based on the same date 6 months ago: today's date, it would April 21st, tomorrow, April 22nd and so on.

In the example of September 30th, February 28th would be ok but if March 1st also ok. It would be a rare occurrence, so not too much of a worry.

When the workbook is opened, the code would look at the absence start date and determine which sheet to move the row to, or if it needs deleting from the last 12 months sheet when it becomes more than 24 months old form the current day.

Hope this is clear, I am very grateful for your time spent helping me.

Kind Regards
Chris
 
Upvote 0
Hi Chris,

It’s a bit difficult without seeing your actual data – it always helps if you can provide (at least) a small sample using the XL2BB add in

The following code is based on your workbook having sheets called "Current 6 months", "Previous 6 months" and "Previous 12 months" – change these names in the code if they’re not correct. The code is based on your data starting in row 2 of each sheet, with row 1 containing the headers. Again, without seeing your data, I don’t know what your date format is – I’ve assumed it’s "dd/mm/yyyy". Change this if it’s something different. Assumed also that your date column to test is column J.

Rather than testing this as a WorkBook.Open event module (which is what you seem to want) try running it first on a copy of your data to see if it’s doing what you want it to. Let me know how it goes.

VBA Code: 
Option Explicit
Sub Chris_010101()
    Application.ScreenUpdating = False
   
    'Set worksheet variables
    Dim WsC6 As Worksheet, WsP6 As Worksheet, WsP12 As Worksheet
    Set WsC6 = Worksheets("Current 6 months")
    Set WsP6 = Worksheets("Previous 6 months")
    Set WsP12 = Worksheets("Previous 12 months")
   
    'Move old records from the Current 6 months sheet first
    Dim d As Date, d2 As Date, LRow As Long
    d = WorksheetFunction.EDate(Date, -6)
    d = Format(d, "dd/mm/yyyy")
    LRow = WsP6.Cells(Rows.Count, 1).End(3).Row + 1
    With WsC6.Range("A1").CurrentRegion
        .AutoFilter 10, "<" & CDbl(d)
        If WsC6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy WsP6.Cells(LRow, 1)
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter
    End With
   
    'Move old records from the Previous 6 months sheet second
    d2 = WorksheetFunction.EDate(Date, -12)
    d2 = Format(d2, "dd/mm/yyyy")
    LRow = WsP12.Cells(Rows.Count, 1).End(3).Row + 1
    With WsP6.Range("A1").CurrentRegion
        .AutoFilter 10, "<" & CDbl(d2)
        If WsP6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy WsP12.Cells(LRow, 1)
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter 10, ">" & CDbl(d), 2, "<" & CDbl(d2)
        If WsP6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter
    End With
   
    'Remove old records from the Previous 12 months sheet last
    d = WorksheetFunction.EDate(Date, -12)
    d = Format(d, "dd/mm/yyyy")
    d2 = WorksheetFunction.EDate(Date, -24)
    d2 = Format(d2, "dd/mm/yyyy")
    With WsP12.Range("A1").CurrentRegion
        .AutoFilter 10, ">" & CDbl(d), 2, "<" & CDbl(d2)
        If WsP12.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter
    End With

    Application.ScreenUpdating = True
End Sub
 
Upvote 0
kevin9999 said:
Hi Chris,

It’s a bit difficult without seeing your actual data – it always helps if you can provide (at least) a small sample using the XL2BB add in

The following code is based on your workbook having sheets called "Current 6 months", "Previous 6 months" and "Previous 12 months" – change these names in the code if they’re not correct. The code is based on your data starting in row 2 of each sheet, with row 1 containing the headers. Again, without seeing your data, I don’t know what your date format is – I’ve assumed it’s "dd/mm/yyyy". Change this if it’s something different. Assumed also that your date column to test is column J.

Rather than testing this as a WorkBook.Open event module (which is what you seem to want) try running it first on a copy of your data to see if it’s doing what you want it to. Let me know how it goes.

VBA Code: 
Option Explicit
Sub Chris_010101()
    Application.ScreenUpdating = False
 
    'Set worksheet variables
    Dim WsC6 As Worksheet, WsP6 As Worksheet, WsP12 As Worksheet
    Set WsC6 = Worksheets("Current 6 months")
    Set WsP6 = Worksheets("Previous 6 months")
    Set WsP12 = Worksheets("Previous 12 months")
 
    'Move old records from the Current 6 months sheet first
    Dim d As Date, d2 As Date, LRow As Long
    d = WorksheetFunction.EDate(Date, -6)
    d = Format(d, "dd/mm/yyyy")
    LRow = WsP6.Cells(Rows.Count, 1).End(3).Row + 1
    With WsC6.Range("A1").CurrentRegion
        .AutoFilter 10, "<" & CDbl(d)
        If WsC6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy WsP6.Cells(LRow, 1)
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter
    End With
 
    'Move old records from the Previous 6 months sheet second
    d2 = WorksheetFunction.EDate(Date, -12)
    d2 = Format(d2, "dd/mm/yyyy")
    LRow = WsP12.Cells(Rows.Count, 1).End(3).Row + 1
    With WsP6.Range("A1").CurrentRegion
        .AutoFilter 10, "<" & CDbl(d2)
        If WsP6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy WsP12.Cells(LRow, 1)
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter 10, ">" & CDbl(d), 2, "<" & CDbl(d2)
        If WsP6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter
    End With
 
    'Remove old records from the Previous 12 months sheet last
    d = WorksheetFunction.EDate(Date, -12)
    d = Format(d, "dd/mm/yyyy")
    d2 = WorksheetFunction.EDate(Date, -24)
    d2 = Format(d2, "dd/mm/yyyy")
    With WsP12.Range("A1").CurrentRegion
        .AutoFilter 10, ">" & CDbl(d), 2, "<" & CDbl(d2)
        If WsP12.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter
    End With

    Application.ScreenUpdating = True
End Sub
Click to expand...
Hello,

Thank you very much for this. The assumptions about sheet names, headers and column J etc. are correct.

My IT Department said no when I asked to install XL2BB but I can send it to my personal computer if needed, just let me know.

I'm just testing it and will come back

Kind Regards
 
Last edited:
Upvote 0
Hi Chris

I thought I'd read your response and you may have since edited it? Something about leaving the filters on at the conclusion & running the code automatically when you open the file? To that end, I've amended to code to leave the filters switched on, and turned the sub into a Workbook_Open event module. Can I assume you know where to put the workbook open code, i.e. not in a standard module? If you're unsure, here's a YouTube video that will help: Microsoft Excel - VBA Code on the Workbook Open Event.

VBA Code: 
Private Sub Workbook_Open()

    Application.ScreenUpdating = False
    
    'Set worksheet variables
    Dim WsC6 As Worksheet, WsP6 As Worksheet, WsP12 As Worksheet
    Set WsC6 = Worksheets("Current 6 months")
    Set WsP6 = Worksheets("Previous 6 months")
    Set WsP12 = Worksheets("Previous 12 months")
    
    'Move old records from the Current 6 months sheet first
    Dim d As Date, d2 As Date, LRow As Long
    d = WorksheetFunction.EDate(Date, -6)
    d = Format(d, "dd/mm/yyyy")
    LRow = WsP6.Cells(Rows.Count, 1).End(3).Row + 1
    With WsC6.Range("A1").CurrentRegion
        .AutoFilter 10, "<" & CDbl(d)
        If WsC6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy WsP6.Cells(LRow, 1)
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        WsC6.ShowAllData
    End With
    
    'Move old records from the Previous 6 months sheet second
    d2 = WorksheetFunction.EDate(Date, -12)
    d2 = Format(d2, "dd/mm/yyyy")
    LRow = WsP12.Cells(Rows.Count, 1).End(3).Row + 1
    With WsP6.Range("A1").CurrentRegion
        .AutoFilter 10, "<" & CDbl(d2)
        If WsP6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy WsP12.Cells(LRow, 1)
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter 10, ">" & CDbl(d), 2, "<" & CDbl(d2)
        If WsP6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        WsP6.ShowAllData
    End With
    
    'Remove old records from the Previous 12 months sheet last
    d = WorksheetFunction.EDate(Date, -12)
    d = Format(d, "dd/mm/yyyy")
    d2 = WorksheetFunction.EDate(Date, -24)
    d2 = Format(d2, "dd/mm/yyyy")
    With WsP12.Range("A1").CurrentRegion
        .AutoFilter 10, ">" & CDbl(d), 2, "<" & CDbl(d2)
        If WsP12.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        WsP12.ShowAllData
    End With

    Application.ScreenUpdating = True
End Sub

Let me know once you've tested it if it needs further tweaking.
 
Upvote 0
Solution
kevin9999 said:
Hi Chris

I thought I'd read your response and you may have since edited it? Something about leaving the filters on at the conclusion & running the code automatically when you open the file? To that end, I've amended to code to leave the filters switched on, and turned the sub into a Workbook_Open event module. Can I assume you know where to put the workbook open code, i.e. not in a standard module? If you're unsure, here's a YouTube video that will help: Microsoft Excel - VBA Code on the Workbook Open Event.

VBA Code: 
Private Sub Workbook_Open()

    Application.ScreenUpdating = False
   
    'Set worksheet variables
    Dim WsC6 As Worksheet, WsP6 As Worksheet, WsP12 As Worksheet
    Set WsC6 = Worksheets("Current 6 months")
    Set WsP6 = Worksheets("Previous 6 months")
    Set WsP12 = Worksheets("Previous 12 months")
   
    'Move old records from the Current 6 months sheet first
    Dim d As Date, d2 As Date, LRow As Long
    d = WorksheetFunction.EDate(Date, -6)
    d = Format(d, "dd/mm/yyyy")
    LRow = WsP6.Cells(Rows.Count, 1).End(3).Row + 1
    With WsC6.Range("A1").CurrentRegion
        .AutoFilter 10, "<" & CDbl(d)
        If WsC6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy WsP6.Cells(LRow, 1)
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        WsC6.ShowAllData
    End With
   
    'Move old records from the Previous 6 months sheet second
    d2 = WorksheetFunction.EDate(Date, -12)
    d2 = Format(d2, "dd/mm/yyyy")
    LRow = WsP12.Cells(Rows.Count, 1).End(3).Row + 1
    With WsP6.Range("A1").CurrentRegion
        .AutoFilter 10, "<" & CDbl(d2)
        If WsP6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy WsP12.Cells(LRow, 1)
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .AutoFilter 10, ">" & CDbl(d), 2, "<" & CDbl(d2)
        If WsP6.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        WsP6.ShowAllData
    End With
   
    'Remove old records from the Previous 12 months sheet last
    d = WorksheetFunction.EDate(Date, -12)
    d = Format(d, "dd/mm/yyyy")
    d2 = WorksheetFunction.EDate(Date, -24)
    d2 = Format(d2, "dd/mm/yyyy")
    With WsP12.Range("A1").CurrentRegion
        .AutoFilter 10, ">" & CDbl(d), 2, "<" & CDbl(d2)
        If WsP12.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        WsP12.ShowAllData
    End With

    Application.ScreenUpdating = True
End Sub

Let me know once you've tested it if it needs further tweaking.
Click to expand...
Hi There,

I did reply and then managed to break it after it worked, I realised I'd leant on the keyboard before closing the VBA window 🤣

This works really well, and I've tested it and it works now upon workbook open.

I really am grateful, all the senior leadership team in my company (including the CEO and board) have been really impressed by this, as it is saving my team almost half a day's worth of work each week, so thank you and @petertenthije for all your help.

If there's any way I can repay you, perhaps making a donation to a charity you are involved with, please let me know.

Kind Regards
Chris
 
Upvote 0
Chris_010101 said:
Hi There,

I did reply and then managed to break it after it worked, I realised I'd leant on the keyboard before closing the VBA window 🤣

This works really well, and I've tested it and it works now upon workbook open.

I really am grateful, all the senior leadership team in my company (including the CEO and board) have been really impressed by this, as it is saving my team almost half a day's worth of work each week, so thank you and @petertenthije for all your help.

If there's any way I can repay you, perhaps making a donation to a charity you are involved with, please let me know.

Kind Regards
Chris
Click to expand...
You're more than welcome Chris, glad we could help and thanks for the feedback. I'm 100% pro bono on this forum but thank you for the kind offer.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Rob_010101
  • Locked
  • Question Question
VBA Code Help
Replies
1
Views
623
Fluff
Fluff
D
  • Solved
VBA Delete Table Rows Given Criteria
2
Replies
10
Views
711
igold
igold
Rob_010101
  • Solved
VB Code Help!!
Replies
3
Views
646
Trebor76
T
D
  • Solved
Need help creating a formula based on VBA function!
Replies
5
Views
320
Trixterz
T
D
  • Solved
VBA Code: Table Column Formatting for Outlook Email
Replies
2
Views
445
Damien Hartzell
D

Forum statistics

Threads
1,223,162
Messages
6,170,431
Members
452,326
Latest member
johnshaji

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top