基于开始和停止时间的条件格式

Question

上周，我找到了一个我一直在寻找的优秀代码。除了我想使用条件格式垂直，而不是原始代码中的水平格式。

原始代码来自：Excel VBA - How do I select a range corresponding to values in previous cells?

我试图修改代码以适应我，但仍然有问题，我不知道是什么。

有我的代码：

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

最后两个是普通代码。我只改变了第一个。

我没有很多关于VBA的编程，但我正在努力。

Jukkis

Answer 1

图片讲千言万语！这是一些有效的代码。我已经大大简化了你的代码，而不是试图了解你做了什么（以及为什么它不起作用）。随意与原版进行比较，并找出为什么一个在另一个没有的时候有效。

注意 - 我使用MATCH函数查找开始/结束的行，然后在一个步骤中格式化整个列。由于我制作了一个较小的工作表，一些行/列编号是不同的 - 应该很容易看到你必须在代码中更改为你工作的东西。

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

结果如下：