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 формулы чувствительны к Calculate Now (F9) событию в Excel.

4. Где-то (например, в обработчике событий Workbook_Open) вызывается служебная процедура StartTime (один раз). Это приведет к автоматическому пересчету столбца Status.

шаги 1, 2, 4 не являются обязательными и не нужны, если обновление не должно быть автоматическим, как конечный пользователь может обновить статусы в любое время, нажав F9