vba - Excel VBA 自动更新列(日期)

Question

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

PS它输入值时代码工作正常。但不自我更新

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是可选的，如果刷新不必是自动的，则不需要，因为最终用户可以随时按 F9 刷新状态