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

[TABLE="class: grid, width: 500, align: center"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]MATCH[/TD]
[TD]620[/TD]
[TD][/TD]
[TD][/TD]
[TD]05:20[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]DATA[/TD]
[TD]1310[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]DATA[/TD]
[TD]1540[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]MATCH[/TD]
[TD]2155[/TD]
[TD][/TD]
[TD][/TD]
[TD]20:55[/TD]
[/TR]
</tbody>[/TABLE]

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?

[Table="width:, class:grid"][tr][td="bgcolor:#C0C0C0"][/td][td="bgcolor:#C0C0C0"]

C​

[/td][td="bgcolor:#C0C0C0"]

D​

[/td][td="bgcolor:#C0C0C0"]

E​

[/td][td="bgcolor:#C0C0C0"]

F​

[/td][td="bgcolor:#C0C0C0"]

G​

[/td][td="bgcolor:#C0C0C0"]

H​

[/td][/tr][tr][td="bgcolor:#C0C0C0"]

3​

[/td][td]MATCH[/td][td]

620​

[/td][td][/td][td][/td][td="bgcolor:#CCFFCC"]

5:30​

[/td][td="bgcolor:#CCFFCC"]G3: =IF(C3 <> "MATCH", "", CEILING(TEXT(D3, "0\:00") - "1:00", "0:15"))[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

4​

[/td][td]DATA[/td][td]

1310​

[/td][td][/td][td][/td][td="bgcolor:#CCFFCC"][/td][td][/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

5​

[/td][td]DATA[/td][td]

1540​

[/td][td][/td][td][/td][td="bgcolor:#CCFFCC"][/td][td][/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

6​

[/td][td]MATCH[/td][td]

2155​

[/td][td][/td][td][/td][td="bgcolor:#CCFFCC"]

21:00​

[/td][td][/td][/tr]
[/table]

 

[Mux99]

How about just a formula?

[TABLE="class: grid"]
<tbody>[TR]
[TD="bgcolor: #C0C0C0"][/TD]
[TD="bgcolor: #C0C0C0"]

C​

[/TD]
[TD="bgcolor: #C0C0C0"]

D​

[/TD]
[TD="bgcolor: #C0C0C0"]

E​

[/TD]
[TD="bgcolor: #C0C0C0"]

F​

[/TD]
[TD="bgcolor: #C0C0C0"]

G​

[/TD]
[TD="bgcolor: #C0C0C0"]

H​

[/TD]
[/TR]
[TR]
[TD="bgcolor: #C0C0C0"]

3​

[/TD]
[TD]MATCH[/TD]
[TD]

620​

[/TD]
[TD][/TD]
[TD][/TD]
[TD="bgcolor: #CCFFCC"]

5:30​

[/TD]
[TD="bgcolor: #CCFFCC"]G3: =IF(C3 <> "MATCH", "", CEILING(TEXT(D3, "0\:00") - "1:00", "0:15"))[/TD]
[/TR]
[TR]
[TD="bgcolor: #C0C0C0"]

4​

[/TD]
[TD]DATA[/TD]
[TD]

1310​

[/TD]
[TD][/TD]
[TD][/TD]
[TD="bgcolor: #CCFFCC"][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="bgcolor: #C0C0C0"]

5​

[/TD]
[TD]DATA[/TD]
[TD]

1540​

[/TD]
[TD][/TD]
[TD][/TD]
[TD="bgcolor: #CCFFCC"][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="bgcolor: #C0C0C0"]

6​

[/TD]
[TD]MATCH[/TD]
[TD]

2155​

[/TD]
[TD][/TD]
[TD][/TD]
[TD="bgcolor: #CCFFCC"]

21:00​

[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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.