Excel VBA 自动更新列（日期）

Question

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

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

这应该适用于时间向前流动的最常见场景：

使用此代码创建实用程序模块 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

将此代码添加到 ThisWorkbook 模块以防止在关闭模块时出现意外行为：
```
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call EndTime
End Sub
```

在 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) 事件敏感。

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

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

Excel VBA 自动更新列（日期）

Excel VBA automatically updating columns (Date)

excel

vba

auto-update