VBA Code Help

[Chris_010101]

Hello,

I use the below code for my absence tracker which was kindly provided on here.

I now need to change it, so instead of looking at current 12 month rolling period and previous 12 month rolling period, 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 between 6 and 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) and delete all rows containing absence older than 24 months from current day.

When the workbook is opened, it automatically moves each absence row between the tabs depending on the absence start date.

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

Hope this makes sense. Original code is below:

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

 

[Fluff]

Duplicate to: VBA Code Change

In future, please do not post the same question multiple times. Per Forum Rules (#12), posts of a duplicate nature will be locked or deleted.

In relation to your question here, I have closed this thread so please continue in the linked thread. If you do not receive a response, you can "bump" it by replying to it yourself, though we advise you to wait 24 hours before doing so, and not to bump a thread more than once a day.