Excel VBA 自动更新列（日期）

Question

我正在创建一个执行客户退货的用户表单。我希望有一个（状态）列会自动更新。它指的是产品的到货日期。它可以工作，但是，当我更改系统日期时，状态栏不会改变。我需要做什么才能使其定期更新？以下是曾经有效的代码。

P.S 输入值时代码可以正常工作。但不会自我更新

Option Explicit
Dim dDate As Date

Private Sub cbP_CodeCR_Change()
Dim row As Long

row = cbP_CodeCR.ListIndex + 2



End Sub

Private Sub Fill_My_Combo(cbo As ComboBox)
    Dim wsInventory As Worksheet
    Dim nLastRow As Long
    Dim i As Long

    Set wsInventory = Worksheets("Inventory")
    nLastRow = wsInventory.Cells(Rows.Count, 1).End(xlUp).row ' Finds last row in Column 1

    cbo.Clear
    For i = 2 To nLastRow 'start at row 2
        cbo.AddItem wsInventory.Cells(i, 1)
    Next i
End Sub

Private Sub cmdCancel_Click()
Unload CustomerReturn
End Sub

Private Sub cmdEnter_Click()
Dim cust_ID As Integer
Dim prod_Code As Integer
Dim arr_date As Date
Dim stat As String
Dim status As String
Dim rowPosition As Integer

rowPosition = 1

Sheets("Customer Return").Select

Sheets("Customer Return").Cells(1, 1).Value = "Customer ID"
Sheets("Customer Return").Cells(1, 2).Value = "Product Code"
Sheets("Customer Return").Cells(1, 3).Value = "Arrival Date"
Sheets("Customer Return").Cells(1, 4).Value = "Status"


Do While (Len(Worksheets("Customer Return").Cells(rowPosition, 1).Value) <> 0)
rowPosition = rowPosition + 1
Loop
cust_ID = txtC_IDCR.Text
Sheets("Customer Return").Cells(rowPosition, 1).Value = cust_ID
prod_Code = cbP_CodeCR.Text
Sheets("Customer Return").Cells(rowPosition, 2).Value = prod_Code
arr_date = txtA_DateCR.Text
Sheets("Customer Return").Cells(rowPosition, 3).Value = arr_date
If ((arr_date - Date) <= 0) Then
Sheets("Customer Return").Cells(rowPosition, 4).Value = "Arrived"
Else
Sheets("Customer Return").Cells(rowPosition, 4).Value = "Waiting for Delivery"
End If

End Sub

Sub Recalc()

Range("C:C").Value = Format("dd/mm/yyyy")
Range("D:D").Calculate

Call StartTime

End Sub

Sub StartTime()

SchedRecalc = Now + TimeValue("00:00:10")
Application.OnTime SchedRecalc, "Recalc"

End Sub

Sub EndTime()

On Error Resume Next
Application.OnTime EarliestTime:=SchedRecalc, _
        Procedure:="Recalc", Schedule:=False

End Sub


Private Sub txtA_DateCR_AfterUpdate()

    With txtA_DateCR
    If .Text = "" Then
    .ForeColor = &HC0C0C0
    .Text = "dd/mm/yyyy"
    End If
    End With

End Sub

Private Sub txtA_DateCR_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    Exit Sub
    If Mid(txtA_DateCR.Value, 4, 2) > 12 Then
        MsgBox "Invalid date, make sure format is (dd/mm/yyyy)", vbCritical
        txtA_DateCR.Value = vbNullString
        txtA_DateCR.SetFocus
        Exit Sub
    End If

    dDate = DateSerial(Year(Date), Month(Date), Day(Date))
    txtA_DateCR.Value = Format(txtA_DateCR.Value, "dd/mm/yyyy")
    dDate = txtA_DateCR.Value
End Sub

Private Sub txtA_DateCR_Enter()

    With txtA_DateCR
    If .Text = "dd/mm/yyyy" Then
    .ForeColor = &H80000008
    .Text = ""
    End If
    End With

End Sub

Private Sub UserForm_Initialize()

txtA_DateCR.ForeColor = &HC0C0C0
txtA_DateCR.Text = "dd/mm/yyyy"
cmdEnter.SetFocus

Fill_My_Combo Me.cbP_CodeCR

End Sub

如果可能的话，非常感谢任何帮助。

Answer 1

这应该在时间向前流动时最常见的情况下工作：

1. 使用此代码创建一个实用模块AnyNameIsGood（它来自Sean Cheshire's answer to similar question，并调整了Recalc 主体）

   Dim ScheduledRecalc As Date
   
   Sub Recalc()
       Sheets("Customer Return").Range("D:D").Calculate
       Call StartTime
   End Sub
   
   Sub StartTime()
       ScheduledRecalc = Now + TimeValue("00:00:10")
       Application.OnTime ScheduledRecalc, "Recalc"
   End Sub
   
   Sub EndTime()
       On Error Resume Next
       Application.OnTime EarliestTime:=ScheduledRecalc, Procedure:="Recalc", Schedule:=False
   End Sub
   

2. 将此代码添加到ThisWorkbook 模块以防止在关闭模块时出现不必要的行为：

   Private Sub Workbook_BeforeClose(Cancel As Boolean)
       Call EndTime
   End Sub
   

3. 在CustomerReturn 模块（表单）中将您当前的代码更改为

   Private Sub cmdEnter_Click()
       ' ...
       arr_date = txtA_DateCR.Text
       Sheets("Customer Return").Cells(rowPosition, 3).Value = arr_date
       Sheets("Customer Return").Cells(rowPosition, 3).NumberFormat = "dd\/mm\/yyyy"
       Sheets("Customer Return").Cells(rowPosition, 4).FormulaR1C1 = "=IF(DAYS(R[0]C[-1],TODAY())<=0,""Arrived"",""Waiting for Delivery"")"
   End Sub
   

   它将格式化日期单元格，并使生成的 Status 公式对 Excel 的 Calculate Now (F9) 事件敏感。

4. 在某处（例如在Workbook_Open 事件处理程序中）调用StartTime 实用程序（一次）。它将触发Status 列的自动重新计算。

步骤1、2、4 是可选的，如果不需要自动刷新，则不需要，因为最终用户可以随时按F9 刷新状态