条件格式化，以根据经过的小时数更改VBA上的单元格颜色

问题描述

我的程序在工作表1上使用一个用户表单，然后自动在下一张工作表上填写信息，包括填写表单的时间。我想根据从工作表2上的自动填充时间过去的时间来更改工作表1上的单元格的颜色。例如，我想在两小时后将工作表1上的单元格颜色更改为黄色。消失，然后在四个小时后再次出现，依此类推。我不确定该如何处理并与当前时间进行比较以了解时间的流逝。

用户表单的代码：

Private Sub cmdOkUpdate_Click()

Dim i As Integer,j As Integer
Dim length As Date

length = Format(Now(),"hh:mm:ss")

For i = 0 To lbxOption.ListCount - 1
    If lbxOption.Selected(i) Then j = j + 1
Next i
If j = 0 Then
    MsgBox "Please select an option. ","Warning"
    Unload Me
    UpdateInfo.Show
ElseIf j = 1 Then
    NoFill = False
End If

strBOL = txtBOL.Value
strID = txtID.Value
details = txtDet.Value
opt = lbxOption.Value
currtime = time()
today = Format(Now(),"MM/DD/YYYY")
emp = TextBox1.Value
dur = Format(Now() - currtime,"hh:mm:ss")

With ActiveCell
    spot = .Offset(-1,0)
    If Len(spot) = 0 Then
        spot = .Offset(1,0)
    Else
        spot = spot
    End If
End With


If NoFill = True Then
    cellFill = ""
ElseIf NoFill = False Then
    With Sheet5

    .Range("A1").Value = "Time"
    .Range("B1").Value = "Date"
    .Range("C1").Value = "Location"
    .Range("D1").Value = "Category"
    .Range("E1").Value = "BOL"
    .Range("f1").Value = "Trailer #"
    .Range("g1").Value = "Details"
    .Range("H1").Value = "EE Name"
    .Range("I1").Value = "Duration"
    
    .Range("A2").EntireRow.Insert
    .Range("A2").Value = currtime
    .Range("B2").Value = today
    .Range("C2").Value = spot
    .Range("D2").Value = opt
    .Range("E2").Value = strBOL
    .Range("F2").Value = strID
    .Range("G2").Value = details
    .Range("H2").Value = emp
    .Range("I2").Value = dur
    
    .Columns("A:I").AutoFit
    
    End With

    If Not IsEmpty(opt) Then
        cellFill = opt & " " & vbCrLf & "BOL (last 5 digits): " & strBOL & " " & vbCrLf & "Trailer # " & strID & " " & vbCrLf & "Details: " & details & " " & vbCrLf & "EE Name: " & emp & " " & vbCrLf
        ActiveCell.Value = cellFill
        Call RealTimeTracker
    End If
    
End If


Unload Me
Sheet1.Activate


End Sub

工作表1的代码


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Set rngBDock = Range("BX7:CO7")
Set rngBulk = Range("BZ21:CG21")
Set rngTransT = Range("BF17:BY17")
Set rngTransT1 = Range("BG21:BY21")
Set rngTDock = Range("BL7:BW7")
Set rngEDock = Range("CP7:CT7")
Set rngNDock = Range("CU7:DC7")
Set rngFence = Range("CQ13:CV13")
Set rngNSide = Range("CW13:DB13")
Set rngGEO = Range("BG28:DD28")
Set rngNight = Range("CH21:DD21")
Set rngNewT = Range("DK31:DK65")
Set rngNewTl = Range("DI31:DI65")
Set rngOff = Range("BN40:CL40")
Set rngOffl = Range("BN42:CL42")
Set rng = Union(rngBDock,rngBulk,rngTransT,rngTransT1,rngTDock,rngEDock,rngNDock,rngFence,rngNSide,rngGEO,rngNight,rngNewT,rngNewTl,rngOff,rngOffl)


    'Makes the realtimetracker macro run everytime a cell in the range is changed
    If Not Intersect(Target,rng) Is nothing Then
        CellInfo.Show
        'ActiveCell.Value = cellFill
        If Not IsEmpty(ActiveCell.Value) Then
            Call RealTimeTracker
        End If
    End If
    
End Sub

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

conditional-formatting excel excel vba