Custom h:mm formatting Macro help

Hello,

I am having trouble in making a Sub procedure for an excel file, and I was wondering if someone could help me write the code. Here is the problem:

I have an excel sheet that only has dates in Column A. In Column B, I have times in h:mm format corresponding to the date. An example section:

A B C D
2/13/2006 22:01 11762 CFM
2/13/2006 22:16 10843 CFM
2/13/2006 22:31 11033 CFM
2/13/2006 22:46 10971 CFM
2/13/2006 23:01 11015 CFM
2/13/2006 23:16 11742 CFM
2/13/2006 23:31 11057 CFM
2/13/2006 23:46 11045 CFM
2/14/2006 0:01 11617 CFM
2/14/2006 0:16 6771 CFM
2/14/2006 0:31 7506 CFM
2/14/2006 0:46 7732 CFM
2/14/2006 1:01 7553 CFM
2/14/2006 1:16 10849 CFM
2/14/2006 1:31 11045 CFM
2/14/2006 1:46 10791 CFM
2/14/2006 2:01 10881 CFM

What I need to do is have only one row in the same date for the specific hour period. i.e, For 2/13/2006, there would be only one row for the hour 23:mm, deleting the other 23:mm for the same date. The criteria is the minutes closest to 00. i.e, if there is 12:05 and 12:23, it would pick 12:05 and delete the other(s).

I could do this manually but it would take forever since there are 17 sheets with around 7000+ rows .

I would really appreciate the help for this! Btw, this is for a college research project relating to airconditioning.

Hello Ralfie,

Add a Standard VBA Code Module to workbook. and then copy and paste the macro code below into it. For this macro to run correctly, it is assumed the data has been sorted as in your post, and the only columns used on the worksheet are A to D. This macro runs on the Active Worksheet.

Sub SortDatesAndTimes()

  Dim Hours(24) As Integer
  Dim LastRow As Long
  Dim N As Integer
  Dim NextDate, ThisDate
  Dim Rng As Range
  Dim Wks As Worksheet
  
    Set Wks = ActiveSheet
    LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
    
      For I = 1 To LastRow - 1
        ThisDate = Wks.Cells(I, "A").Value
        N = Hour(Wks.Cells(I, "D").Value)
          If Hours(N) = 0 Then
             Hours(N) = N
          Else
             Wks.Range(Cells(I, "A"), Cells(I, "D")).ClearContents
          End If
        NextDate = Wks.Cells(I + 1, "A").Value
          If ThisDate <> NextDate Then Erase Hours()
      Next I
      
      Set Rng = ActiveSheet.Range(Cells(1, "A"), Cells(LastRow, "D"))
        Rng.SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)
 
End Sub

Sincerely,
Leith Ross

Thanks Leith,

I couldn't get the code to work because of this line:
N = Hour(Wks.Cells(I, "D").Value)

It says that there is a Run-time error 13 type-mismatch . I'm sure that there is an easy way to debug it, but I'm a real noob at VB... I'll play around with it and see what happens.

Thanks anyway,

Ralfie

Hello Ralfie,

The Excel documentation says Hour returns a Variant (Integer). There shouldn't be a problem, but if the code isn't working we'll change N to a Variant type.

Find the Dim N As Integer line at the top of code and change it to... Dim N As Variant. That should do it. The code runs fine on my machine as is.

Sincerely,
Leith Ross

Thanks Leith,

Now I can finally sort the data...

Ralfie

Hello Ralfie,

I noticed that the sort doesn't work correctly for midnight "0:00". This code corrects the problem. I apologize for any inconvenience this may have caused.

Sub SortDatesAndTimes()

  Dim Hours(24) As Variant
  Dim LastRow As Long
  Dim N As Variant
  Dim NextDate, ThisDate
  Dim Rng As Range
  Dim Wks As Worksheet
  
    Set Wks = ActiveSheet
    LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
    
      For I = 1 To LastRow - 1
        ThisDate = Wks.Cells(I, "A").Value
        N = Hour(Wks.Cells(I, "B").Value)
          If IsEmpty(Hours(N)) Then
             Hours(N) = N
          Else
             Wks.Range(Cells(I, "A"), Cells(I, "D")).ClearContents
          End If
        NextDate = Wks.Cells(I + 1, "A").Value
          If ThisDate <> NextDate Then Erase Hours()
      Next I
      
    On Error Resume Next
      Set Rng = ActiveSheet.Range(Cells(1, "A"), Cells(LastRow, "D"))
        Rng.SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)

End Sub

Sincerely,
Leith Ross