Need help with this code, to purge records older than 8 hrs

[jdr360]

I have received some great help from this Forum, hoping someone can help me with this one also. I have a worksheet, with records (database). In Column B is the date the record was created (dd-MMM-yyyy format). In Column C I have the time is was created (HH:MM 24hr format). The problem I`m having, is purging the records older than 8 hours from current system time. This code works at purging previous day records for the current finance period, but it is not taking into account 24hr format and after midnight for records older than 8 hours. I have tried many different approaches to this but still unable to figure this out. This is the code I have since the last time I tried to figure this out:

        '------------------------
        ' Current Finance Period
        '------------------------
        cSheet = CStr(Format(cStartDate, "dd-MMM-yyyy")) & " - " & CStr(Format(cEndDate, "dd-MMM-yyyy")) `Set the sheet name to use (current finance period)
        CreateSheetIf (cSheet) `Create sheet if not exists
        cFTarget = wbFinance.Worksheets(cSheet).UsedRange.Rows.Count `count the rows used
        Set wscFinance = wbFinance.Worksheets(cSheet)
        MRCForm.Caption = "MRC [ Processing... " & cSheet & " Ready to Finance records... Please wait... ]"
        Me.sysMsgBox.Value = " Purging records, between " & cSheet & ", marked Ready for Finance..."
        Application.ScreenUpdating = False
        If cFTarget = 1 Then
            If Application.WorksheetFunction.CountA(wscFinance.UsedRange) = 0 Then cFTarget = 0
        End If
        Source = wsMRC.UsedRange.Rows.Count
        Set xRg = wsMRC.Range("AF2:AF" & Source)
        Set dRg = wsMRC.Range("B2:B" & Source) `Date column in dd-MMM-yyyy format
        Set tRg = wsMRC.Range("C2:C" & Source) `Time column in HH:MM 24hr format
        On Error Resume Next
        For K = 1 To xRg.Count
            If dRg(K).Value = "" Or tRg(K).Value = "" Or xRg(K).Value = "" Then Exit For
                If Format(dRg(K).Value, "dd-MMM-yyyy") >= Format(cStartDate, "dd-MMM-yyyy") And Format(dRg(K).Value, "dd-MMM-yyyy") < CStr(Format(Now, "dd-MMM-yyyy")) Then ' If date is within current finance period then
                    If CStr(xRg(K).Text) = "Y" Then
                        xRg(K).EntireRow.Copy Destination:=wscFinance.Range("A" & cFTarget + 1)
                        xRg(K).EntireRow.Delete
                        cFTotal = cFTotal + 1
                        MRCForm.Caption = "MRC [ Processing... " & cSheet & " (" & cFTotal & ") Please wait... ]"
                        If CStr(xRg(K).Value) = "Y" Then
                            K = K - 1
                        End If
                        cFTarget = cFTarget + 1
                    End If
                End If
        Next
        Source = wsMRC.UsedRange.Rows.Count
        Set xRg = wsMRC.Range("AF2:AF" & Source)
        Set dRg = wsMRC.Range("B2:B" & Source) `Date column in dd-MMM-yyyy format
        Set tRg = wsMRC.Range("C2:C" & Source) `Time column in HH:MM 24hr format
        On Error Resume Next
        For K = 1 To xRg.Count
            If dRg(K).Value = "" Or tRg(K).Value = "" Or xRg(K).Value = "" Then Exit For
                If Format(dRg(K).Value, "dd-MMM-yyyy") = CStr(Format(Now, "dd-MMM-yyyy")) And Format(tRg(K).Value, "HH:MM") <= Format(Now - TimeValue("08:00"), "HH:MM") Then ' If time is greater or equal to 8 hours ago then
                    If CStr(xRg(K).Text) = "Y" Then
                        xRg(K).EntireRow.Copy Destination:=wscFinance.Range("A" & cFTarget + 1)
                        xRg(K).EntireRow.Delete
                        cFTotal = cFTotal + 1
                        MRCForm.Caption = "MRC [ Processing... " & cSheet & " (" & cFTotal & ") Please wait... ]"
                        If CStr(xRg(K).Value) = "Y" Then
                            K = K - 1
                        End If
                        cFTarget = cFTarget + 1
                    End If
                End If
        Next
        wscFinance.Columns("A:AM").AutoFit
        Application.ScreenUpdating = True
        Application.ScreenUpdating = True

I know the code is not very clean, just trying to get something that will function for now, will try to clean it up at a later date. Might even look at creating Functions as reusable code is more efficient.

 

[Dryver14]

What time is this actually being looked at.

If normal hours could you not do an additional if statement, just if date is less than today?

 

[jdr360]

This is done at any time of the day. I have tried many variations of this, just can`t get it to look pass midnight. Let`s say it is currently 24-Feb-2018 at 0100hrs...it should not purge records stamped 23-Feb-2018 1700hrs to 2359hrs, but it purges all previous day records. As for the current day, it works fine. Maybe I`m missing something simple, these late night working hours are killing my brain cells lol.

 

[Dryver14]

The only way I have achieved this is through using the now function to generate a combined date and time then format the output cell as [h]:mm

this gives a result from 27/02/2018 21:15 in A1 28/02/2018 03:18 in A2 sum in C3 A2-A1= 6:02

 

[jdr360]

I have tried something similar a few weeks ago, not an ideal solution, but I may have to revisit it again. Was hoping someone has a simple solution, as it would mean a possible re-write of the code. I`m too tired to figure this out tonight. Getting ready to go home, will try to look at this again tomorrow.

 

[Dryver14]

I'll keep thinking about it too

 

[jdr360]

I have not found a solution to this yet, anyone able to help?

 

[jdr360]

Still unable to get this to function correctly. This is what I have changed to:

        TestCurrentTime = Format(Now() - 8, "HH:MM")
        If TestCurrentTime < 0 Then
            TestDate = Format(Now() - 1, "dd-MMM-yyyy")
            TestTime = 24 + TestCurrentTime 'TestCurrentTime should be a negative value
        Else
            TestDate = Format(Now(), "dd-MMM-yyyy")
            TestTime = TestCurrentTime
        End If
        cSheet = CStr(Format(cStartDate, "dd-MMM-yyyy")) & " - " & CStr(Format(cEndDate, "dd-MMM-yyyy"))
        CreateSheetIf (cSheet)
        cFTarget = wbFinance.Worksheets(cSheet).UsedRange.Rows.Count
        Set wscFinance = wbFinance.Worksheets(cSheet)
        MRCForm.Caption = "MRC [ Proccessing... " & cSheet & " Ready to Finance records... Please wait... ]"
        Application.ScreenUpdating = False
        If cFTarget = 1 Then
            If Application.WorksheetFunction.CountA(wscFinance.UsedRange) = 0 Then cFTarget = 0
        End If
        Source = wsMRC.UsedRange.Rows.Count
        Set xRg = wsMRC.Range("AF2:AF" & Source)
        Set dRg = wsMRC.Range("B2:B" & Source)
        Set tRg = wsMRC.Range("C2:C" & Source)
        On Error Resume Next
        For K = 1 To xRg.Count
            If dRg(K).Value = "" Or tRg(K).Value = "" Or xRg(K).Value = "" Then Exit For
                If Format(dRg(K).Value, "dd-MMM-yyyy") >= Format(cStartDate, "dd-MMM-yyyy") And Format(dRg(K).Value, "dd-MMM-yyyy") < TestDate Then
                    If CStr(xRg(K).Text) = "Y" Then
                        xRg(K).EntireRow.Copy Destination:=wscFinance.Range("A" & cFTarget + 1)
                        xRg(K).EntireRow.Delete
                        cFTotal = cFTotal + 1
                        If CStr(xRg(K).Value) = "Y" Then
                            K = K - 1
                        End If
                        cFTarget = cFTarget + 1
                    End If
                End If
        Next
        '----------------------------------------------------------------------------
        ' Current Finance Period - Records older than 8 hours from current date/time
        '----------------------------------------------------------------------------
        Source = wsMRC.UsedRange.Rows.Count
        Set xRg = wsMRC.Range("AF2:AF" & Source)
        Set dRg = wsMRC.Range("B2:B" & Source)
        Set tRg = wsMRC.Range("C2:C" & Source)
        On Error Resume Next
        For K = 1 To xRg.Count
            If dRg(K).Value = "" Or tRg(K).Value = "" Or xRg(K).Value = "" Then Exit For
                If Format(dRg(K).Value, "dd-MMM-yyyy") = TestDate And Format(tRg(K).Value, "HH:MM") = TestTime Then ' If time is greater or equal to 8 hours ago then
                    If CStr(xRg(K).Text) = "Y" Then
                        xRg(K).EntireRow.Copy Destination:=wscFinance.Range("A" & cFTarget + 1)
                        xRg(K).EntireRow.Delete
                        cFTotal = cFTotal + 1
                        If CStr(xRg(K).Value) = "Y" Then
                            K = K - 1
                        End If
                        cFTarget = cFTarget + 1
                    End If
                End If
        Next

Still does not do what I need it to do. There are rows of data I need to process into Finance periods. Each finance period is roughly 13 days long. The record log date is stored in Column B (Formatted dd-MMM-yyyy) and time is stored in Column C (Formatted in 24 hr clock HH:MM). All records will be moved into another Wookbook (Finance), into their respective Worksheets (worksheet names are the finance periods). Example, lets assume previous finance period is '18-Feb-2018 - 03-Mar-2018' and current is '04-Mar-2018 - 17-Mar-2018'. I need to process all records for previous finance period (if they have not been done already) and all current fiance period records up to current system day. For the current system day, I need to only move records that are 8 hours old. It will also have to take into account records that go back pass midnight 00:00. Anyone able to help out in cleaning up this code? Possibly using Functions (as reusable code is more efficient). I can get part of the record purging process to work, but I am stuck on getting it to work pass midnight. I'm not an expert at this, I have learned a lot, but this issue I just can't solve. The previous records purge part works fine, since I do not need to worry about time. It's the current finance period I can't get to work correctly. If I include the entire code for the purge process, would that help people to help me try to clean this up and solve this issue?