Help with macro that removes excess time records

[wherbjr35]

Good evening forumers,

I have been working (and been somewhat unsuccessful) on a macro that will remove the extra records from this data set. The records were recorded minute-by-minute, over a range of days, and I need to truncate the records so that each day only has hourly records remaining.

In the code below, there are a couple of loops, the first checks to see that the date on line x equals the date on line x + 1 --- i need this to catch when the date changes. My second loop takes the time and adds 60 minutes to it -- i need this to compare the time, as I am looking for my readings to be exactly 60 minutes from one another. In my last loop, I was trying to print a status of (greater than 60 minutes, less than 60 minutes, or equal to 60 minutes, with the last being the one I am interested in.

Then, my hope was to be able to filter out what i dont want and delete, leaving only readings that are 60 minutes from one another, for each day given.

My first 2 loops do what I want, but i cant get the last one to work. Here is what I have come up with codewise, and I have attached a small data sample.

Sub convert_to_minute_by_minute()

Dim range_b, range_c, range_i As Range
Dim newtime
Dim z

Set range_b = Range("B18:B1923")  'date range
Set range_c = Range("C18:C1923") 'time range
Set range_i = Range("I18:I1923") 'new time range

For x = 1 To range_b.Count
    If range_b(x) = range_b(x + 1) Then
        Range("G17").Offset(x, 0).Value = "dates match"
    ElseIf range_b(x) <> range_b(x + 1) Then
        Range("G17").Offset(x, 0).Value = "dates do not match"
    End If
Next
MsgBox "Done checking the dates"

For y = 1 To range_c.Count
    newtime = DateAdd("n", 60, range_c(y))
    Range("I17").Offset(y, 0).Value = "" & newtime
Next
MsgBox "Done adding 60 minutes to each time"
        
'this loop should start at time(1) in range_C and looks for when a time in range_I is 60 minutes from it. When found, that becomes the first hourly reading that is kept, and so on.  The step to actually write out each time is not mandatory, i was using it to help me out.
 
For w = 1 To range_i.Count
     For z = 1 To range_c.Count          
          If range_c(z) > range_i(w) Then
                Range("h17").Offset(w, 0).Value = "greater than"
          ElseIf range_c(z) < range_i(w) Then
                Range("h17").Offset(w, 0).Value = "less than"
          ElseIf range_c(z) = range_i(w) Then
                Range("h17").Offset(w, 0).Value = "equal to"
          End If
     Next
Next
MsgBox "Done with time_status"
End Sub

I realize that my last loop is no where near where it needs to be, so any form of help or thoughts on another approach would be awesome.

Much thanks in advance,

wherbjr35

[JBeaucaire]

Bare bones simple.... remove all but the first entry for each hour in the table... this matches all the entries except the first since it didn't start at the top of the hour....

Sub LeaveFirstMinuteEachHourOnly()
Dim LR As Long
LR = Range("B" & Rows.Count).End(xlUp).Row

    Range("J18") = 1
    Range("J19:J" & LR).FormulaR1C1 = "=IF(HOUR(RC[-7])=HOUR(R[-1]C[-7]),1, """")"
    Range("J19:J" & LR).SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow.Delete xlShiftUp
    Range("J18:J" & LR).ClearContents
    
End Sub

Instead of looping through data one row at a time, if you can envision a worksheet formula that does the same "test", then enter that formula in the whole range all at once to give results you can filter on, then filter them all out all at once, singe commands.

[JBeaucaire]

And I realized we could just as easily construct a formula to grab every hour starting at the same minute that started your table, so here's a second option:

Sub LeaveFirstMinuteEachHourOnly()
Dim LR As Long
LR = Range("B" & Rows.Count).End(xlUp).Row

    Range("I18").Formula = "=C18"
    Range("I19:I" & LR).FormulaR1C1 = "=IF(LOOKUP(99^99, R18C9:R[-1]C9)+TIMEVALUE(""00:60:00"")=RC[-6], RC[-6], """")"
    Range("I19:I" & LR).SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete xlShiftUp
    Range("I18:I" & LR).ClearContents
    
End Sub

[MarvinP]

Hi wherbjr35,

Find the attached with 2 helper columns. You could sort by the Keep column and delete all the Toss rows.
No VBA Needed. Do you require VBA?

[wherbjr35]

Jerry and Marvin,

Thank you very much for assisting me with this task. Marvin, your solution worked perfectly. Both solutions were solid, but for some reason (probably related to my machine) Excel kept crashing when i ran both of your solutions Jerry. Nevertheless, I appreciate it greatly.

[JBeaucaire]

If that takes care of your need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.