Question

下面的代码遍历每一行数据，如果满足条件，则删除Outlook约会。它还会在处理每一行时显示进度条更新，然后显示一个msgbox，说明已花费了多长时间-有什么办法可以让我在进度条甚至状态栏上显示剩余时间？ / p>

Sub DeleteAfterResponseCoring()

Dim i As Long, j As Long
Dim wb              As Workbook
Dim ws              As Worksheet
Dim objOutlook      As Outlook.Application
Dim objNamespace    As Outlook.Namespace
Dim objFolder       As Outlook.MAPIFolder
Dim objAppointment  As Outlook.AppointmentItem

Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = ThisWorkbook.ActiveSheet

Dim StartTime As Double
Dim MinutesElapsed As String

'Remember time when macro starts
  StartTime = Timer


Dim r As Long
Dim pctdone As Single
r = ws.Cells(Rows.Count, 2).End(xlUp).Row

'(Step 1) Display your Progress Bar
ufProgress.LabelProgress.Width = 0
ufProgress.Show
For i = 3 To r
'(Step 2) Periodically update progress bar
    pctdone = i / r
    With ufProgress
        .LabelCaption.Caption = "Processing Row " & i & " of " & r & vbCrLf & "Close window when complete."
        .LabelProgress.Width = pctdone * (.FrameProgress.Width)
    End With
    DoEvents
        '-------



For j = oItems.Count To 1 Step -1

    If (ActiveSheet.Name) = "Coring" And ws.Cells(i, 11).Value = "N/A" And ws.Cells(i, 8).Value = "Yes" Then
    ws.Cells(i, 15) = "Yes"
        Set objAppointment = oItems.Item(j)
        With objAppointment
            If .Subject = "Send reminder email - LBR " + ws.Cells(i, 3).Value Or .Subject = "FINAL DEADLINE - LBR " + ws.Cells(i, 2).Value Then
                objAppointment.Delete
            End If
            End With
            End If
Next j
Next i

If i = r Then Unload ufProgress

'Determine how many seconds code took to run
  MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")

'Notify user in seconds
  MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

End Sub

Answer 1

数学家可能会对此大笑，也许有一种更简单的方法..但尝试在循环中添加以下行：

Application.Statusbar = Round(((Timer - StartTime) / pctdone) - (Timer - StartTime), 0) & " seconds remaining."

简单地说，它需要花费到目前为止的时间，然后将其除以完成百分比，以计算出估计的完成时间，该时间可以用来计算剩余的时间。我想。

完成后，您需要设置Application.Statusbar = False

Answer 2

我找不到解决方案，所以我最终开设了一个课程来估算剩余时间。这只是一个简单的线性外推，您可以指定在多远后用作估计中的样本。要使用它，请添加一个名为 TimeRemaining 的类并添加以下代码：

Option Explicit

Private Observations() As Variant

Private Sub Class_Initialize()
    ReDim Observations(0)
    Me.AddObservation 0

End Sub

Public Sub AddObservation(Percentage As Single)
    Dim NewObservation(1)
    NewObservation(0) = Percentage
    NewObservation(1) = Timer
    
    ReDim Preserve Observations(UBound(Observations) + 1)
    Observations(UBound(Observations)) = NewObservation

End Sub

Public Property Get RemainingTimeEstimate(Optional Offset As Long = 1)
    'The offset is how many past observations you want to base the time estimate on.
    Dim Observation1
    Dim Observation2
    
    If Offset + 1 > UBound(Observations) Then
        Offset = UBound(Observations) - 1
    
    End If

    Observation1 = Observations(UBound(Observations) - Offset)
    Observation2 = Observations(UBound(Observations))
    
    Dim PercentageBetweenObs As Single
    Dim TimeBetweenObs As Single
    Dim PercentRemaining As Single
    TimeBetweenObs = Observation2(1) - Observation1(1)
    PercentageBetweenObs = Observation2(0) - Observation1(0)
    PercentRemaining = 1 - Observation2(0)

    'RemainingTime = ( Percentage remaining / Percentage observed ) * Observation Time
    RemainingTimeEstimate = Round(TimeBetweenObs * PercentRemaining / PercentageBetweenObs, 0)
End Property

在要估计剩余时间的代码中初始化类。假设您的代码有一些您想要计时的循环，请定期调用 AddObservation 并将完成的百分比（作为小数）传递给它。然后要获得以秒为单位的剩余时间估计值，请调用 RemainingTimeEstimate。这是一个示例用法，使用 mod 10 每 10 个循环更新一次：

Sub TestTimeRemaining()
    Dim k As Long
    Dim Total As Long
    Total = 100
    Dim TimeRemainingEstimate As TimeRemaining
    Set TimeRemainingEstimate = New TimeRemaining
    
    For k = 1 To Total
        
        If k Mod 10 = 0 Then
            Application.Wait (Now + TimeValue("0:00:1"))
            Dim PercentageComplete As Single
            PercentageComplete = k / Total
            TimeRemainingEstimate.AddObservation PercentageComplete
                        
            Debug.Print "Time remaining: " & TimeRemainingEstimate.RemainingTimeEstimate(3) & "s"
        
        End If
        
    Next k

End Sub

显示宏的剩余时间

2 个答案: