Round up time by quarter of the hour in VBA

[Mux99]

Hello

The macro below works well for converting military time to regular time and adjusts the one difference in timezone. I would like to round up the outputted time by quarter of the hour as I am currently doing it manually after running the macro using the MROUND function. Ex 05:20=05:30 & 20:55=21:00

		MATCH	620			05:20
		DATA	1310
		DATA	1540
		MATCH	2155			20:55

<tbody>
</tbody>

For Each Cell In Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row)
If Cell.Value = "MATCH" Then Cell.Offset(, 1).Value = TimeValue(Format(Cell.Offset(, 4).Value, "0\:00")) - TimeValue("01:00")
Next

 

[shg]

How about just a formula?

	C​	D​	E​	F​	G​	H​
3​	MATCH	620​			5:30​	G3: =IF(C3 <> "MATCH", "", CEILING(TEXT(D3, "0\:00") - "1:00", "0:15"))
4​	DATA	1310​
5​	DATA	1540​
6​	MATCH	2155​			21:00​

 

[Mux99]

How about just a formula?

	C​	D​	E​	F​	G​	H​
3​	MATCH	620​			5:30​	G3: =IF(C3 <> "MATCH", "", CEILING(TEXT(D3, "0\:00") - "1:00", "0:15"))
4​	DATA	1310​
5​	DATA	1540​
6​	MATCH	2155​			21:00​

<tbody>
</tbody>

I would like to add it to the macro as there will be multiple conditions. If C equals "MATCH" then round up to the next 15min interval and other values that will need to be rounded up by 10min & 30min intervals depending on the text in column C.

 

[shg]

Sub Mux()
  Dim cell As Range
  Dim r As Range
  
  Set r = FindAll("Match", Columns(3))
  If Not r Is Nothing Then
    For Each cell In r
      cell.Offset(, 4).Value = Ceiling(TimeValue(Format(cell.Offset(, 1).Value, "0\:00")) - TimeValue("1:00"), TimeValue("0:15"))
    Next cell
  End If
End Sub

Public Function FindAll(vWhat As Variant, _
                        rSearch As Range, _
                        Optional LookIn As XlFindLookIn = xlValues, _
                        Optional LookAt As XlLookAt = xlWhole, _
                        Optional MatchCase As Boolean = False) As Range

  Dim cell          As Range
  Dim sAdr          As String

  Set cell = rSearch.Find(What:=vWhat, _
                          LookIn:=LookIn, _
                          LookAt:=LookAt, _
                          MatchCase:=MatchCase, _
                          SearchFormat:=False)
  If Not cell Is Nothing Then
    Set FindAll = cell
    sAdr = cell.Address
    Do
      Set FindAll = Union(FindAll, cell)
      Set cell = rSearch.FindNext(cell)
    Loop While cell.Address <> sAdr
  End If
End Function

Function Ceiling(d As Double, ByVal s As Double) As Double
  Dim q             As Double
  Dim iSgn          As Integer

  If s < 0 Then s = -s
  
  iSgn = Sgn(d)
  If iSgn = -1 Then d = -d

  q = d / s
  If q <> Int(q) Then q = Int(q) + 1#
  Ceiling = iSgn * q * s
End Function

 

[Norie]

Try this.

For Each Cell In Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row)
    If Cell.Value = "MATCH" Then
        Cell.Offset(, 1).Value = Application.Ceiling(TimeValue(Format(Cell.Offset(, 4).Value, "0\:00")) - TimeValue("01:00"), TimeSerial(0, 15, 0))
    End If
Next

 

[Mux99]

Try this.

For Each Cell In Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row)
    If Cell.Value = "MATCH" Then
        Cell.Offset(, 1).Value = Application.Ceiling(TimeValue(Format(Cell.Offset(, 4).Value, "0\:00")) - TimeValue("01:00"), TimeSerial(0, 15, 0))
    End If
Next

Thanks for this. The function I ended up using is:

​For Each Cell In Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row)
If Cell.Value = "MATCH" Then Cell.Offset(, 4).Value = Application.WorksheetFunction.Ceiling(TimeValue(Format(Cell.Offset(, 1).Value, "0\:00")) - TimeValue("01:00"), TimeValue("00:15"))
Next

Is there any downside to using Application Worksheet Functions as this seems like an easier solution than the answers above?

 

[shg]

Significantly slower.