Conditional formating based on start and stop time

Question

Last week, I found an excellent code that I've been looking for. Except that I would like to use conditional formatting vertical, not horizontal as in the original code.

The orginal code is found from: Excel VBA - How do I select a range corresponding to values in previous cells?

I tried to modify the code to suit me, but there is still something wrong and I don't know what.

There is my code:

Sub tee()
    Dim startRow As Long
    Dim endRow As Long
    Dim i As Long
    Dim j As Long

    Dim ws As Excel.Worksheet
    Dim entryTime As Single
    Dim exitTime As Single
    Dim formatRange As Excel.Range

    Set ws = ActiveSheet

     startRow = ws.Range("19:19").Row
     endRow = ws.Range("56:56").Row

    Call clearFormats

     For i = 3 To ws.Cells(1, 1).End(xlToRight).Column
        entryTime = ws.Cells(15, i).Value
        exitTime = ws.Cells(16, i).Value

        Set formatRange = Nothing

      For j = startRow To endRow
            If (ws.Cells(j, 2).Value > exitTime) Then
                Exit For
            End If

             If ((entryTime < ws.Cells(j, 2).Value) And (ws.Cells(j, 2).Value < exitTime)) Then

                If (formatRange Is Nothing) Then
                   Set formatRange = ws.Cells(j, i)
                Else
                   Set formatRange = formatRange.Resize(, formatRange.Rows.Count + 1)

                    End If
            End If
        Next j

        If (Not formatRange Is Nothing) Then
            Call formatTheRange(formatRange, ws.Cells(j, "A").Value)
        End If
    Next i
End Sub



Private Sub clearFormats()

    With ActiveSheet.Range("C19:AA56")
        .clearFormats
        .ClearContents
    End With

End Sub




Private Sub formatTheRange(ByRef r As Excel.Range, ByRef callsign As String)

  r.HorizontalAlignment = xlCenter
  r.Merge
  r.Value = callsign

    ' Apply color
    With r.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .Color = 3
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With

    ' Apply borders
    With r.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With r.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With r.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
     End With
     With r.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
     End With
End Sub

The last two is ordinary code. I have change only the first one.

I don't have a lot of programming with VBA, but I'm trying hard.

Jukkis

Answer 1

The picture tells a thousand words! Here is some code that works. I have simplified your code considerably, rather than trying to learn what you did (and why it didn't work). Feel free to compare with your original, and figure out why one works when the other didn't.

Note - I use the MATCH function to find the rows where you start/end, then format the entire column in a single step. Since I made a smaller sheet, some of the row/column numbers are different - it should be easy to see where you have to change things in the code to work for you.

Option Explicit

Sub makeTimeGraph()
    Dim startRow As Long
    Dim endRow As Long
    Dim entryTimeRow As Long
    Dim entryTimeFirstCol As Long

    Dim ws As Excel.Worksheet
    Dim timeRange As Range
    Dim c
    Dim timeCols As Range
    Dim entryTime
    Dim exitTime
    Dim formatRange As Excel.Range
    Dim eps
    eps = 1e-06 ' a very small number - to take care of rounding errors in lookup


    ' change these lines to match the layout of the spreadsheet
    ' first cell of time entries is B1 in this case:
    entryTimeRow = 1
    entryTimeFirstCol = 2
    ' time slots are in column A, starting in cell A3:
    Set timeRange = Range("A3", [A3].End(xlDown))

    ' columns in which times were entered:
    Set ws = ActiveSheet
    Set timeCols = Range("B1:H1) ' select all the columns you want here, but only one row

    ' clear previous formatting
    Range("B3", ws.Cells.SpecialCells(xlCellTypeLastCell)).clearFormats

    ' loop over each of the columns:
    For Each c In timeCols.Cells
      If IsEmpty(c) Then Goto nextColumn
      entryTime = c.Value
      exitTime = c.Offset(1, 0).Value
      startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
      endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
      Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
      Call formatTheRange(formatRange)
nextColumn:
    Next c

End Sub


Private Sub formatTheRange(ByRef r As Excel.Range)

  r.HorizontalAlignment = xlCenter
  r.Merge

    ' Apply color
    With r.Interior
        .Pattern = xlSolid
        .Color = 3
        .TintAndShade = 0.8
    End With

End Sub

Here is the result: