Excel VBA自动更新列（Date）

我正在创build一个用户表单来做客户退货。 我希望有一个（状态）列将自动更新自己。 它是指产品的到达date。 它工作，但是，当我改变系统date，状态栏不会改变。 我需要做些什么才能定期更新？ 以下是任何工作的代码。

PS它的代码在input值时工作正常。 但不自行更新

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

当时间stream逝时，这应该在最常见的情况下工作：

1. 使用此代码创build一个实用程序模块AnyNameIsGood （它来自Sean Cheshire对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模块以防止在closures模块时出现不需要的行为：

    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 

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

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

步骤4是可选的，如果刷新不必是自动的，最终用户可以通过按F9随时刷新状态