如何为VBA进度条添加已耗时、剩余时间及完成通知功能

改造步骤 #

1. 调整进度条窗体

在你现有的ufProgress窗体上新增2个标签控件，用于展示时长信息：

• 标签1命名为lblElapsed，默认显示文本可设为「已运行时长：00:00」
• 标签2命名为lblRemaining，默认显示文本可设为「预估剩余时长：00:00」

2. 替换主模块代码

以下是优化并新增了你要的三个功能的完整代码，同时优化了重复取总行数的冗余逻辑，能一定程度提升运行速度：

Sub ZipCodeToSheet()
    Dim MapSheet As Worksheet
    Dim ws As Worksheet
    Dim code As String
    Dim sh As Worksheet
    Dim TotalRows As Long ' 提前存储总行数，避免重复计算
    Dim StartTime As Double ' 记录程序启动时间
    Dim ElapsedTime As Double, RemainingTime As Double
    Dim pctdone As Double
    
    Set ws = ThisWorkbook.Worksheets("DATA SHEET")
    Set MapSheet = ThisWorkbook.Worksheets("Zip Code Match")
    TotalRows = ws.Range("J999999").End(xlUp).Row ' 只计算一次总行数
    StartTime = Timer ' 记录开始时间
    
    ws.Activate
    ' 初始化进度条
    ufProgress.LabelProgress.Width = 0
    ufProgress.Show
    
    For i = 1 To TotalRows
        pctdone = i / TotalRows
        ' 计算已运行时长和剩余时长
        ElapsedTime = Timer - StartTime
        If pctdone > 0 Then
            RemainingTime = ElapsedTime / pctdone - ElapsedTime
        Else
            RemainingTime = 0
        End If
        
        ' 更新进度条和时长显示
        With ufProgress
            .LabelCaption.Caption = "Processing Row " & i & " of " & TotalRows
            .LabelProgress.Width = pctdone * (.FrameProgress.Width)
            ' 格式化时长为分:秒显示
            .lblElapsed.Caption = "已运行时长：" & Format(ElapsedTime / 86400, "hh:mm:ss")
            .lblRemaining.Caption = "预估剩余时长：" & Format(RemainingTime / 86400, "hh:mm:ss")
        End With
        ufProgress.Repaint
        DoEvents
        
        ' 原有业务逻辑保持不变
        code = Trim(ws.Range("J1").Offset(i, 0).Text)
        With MapSheet.Cells
            On Error GoTo nextva:
            r = .Find(What:=code, After:=MapSheet.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row
            c = .Find(What:=code, After:=MapSheet.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Column - 1
        End With
        ws.Range(ws.Cells(i + 1, 1), ws.Cells(i + 1, 22)).Copy
        newname = MapSheet.Range("A1").Cells(r, c).MergeArea.Cells(1, 1).Value
        Set sh = ThisWorkbook.Worksheets(fuzzymatch(CStr(newname)))
        ar = sh.Range("B999999").End(xlUp).Row + 1
        sh.Range(sh.Cells(ar, 2), sh.Cells(ar, 23)).PasteSpecial xlPasteValues
thosc:
    Next
    
    ' 关闭进度条
    Unload ufProgress
    ' 处理完成提示
    MsgBox "数据处理完成！共处理" & TotalRows & "行记录，总耗时：" & Format((Timer - StartTime) / 86400, "hh:mm:ss"), vbInformation, "处理完成"
    
    Exit Sub
nextva:
    Resume thosc

End Sub


Function fuzzymatch(s As String) As String
    Dim ab As Integer
    Dim highest As Integer
    Dim ss As String
    highest = -1
    For Each sh In ThisWorkbook.Sheets
        ab = 0
        If s = sh.Name Then
            fuzzymatch = s
            Exit Function
        End If
        For i = 1 To Len(s)
            If InStr(sh.Name, (Mid(s, i, 1))) > 0 Then
                ab = ab + 1
            End If
        Next
        If ab > highest Then
            highest = ab
            ss = sh.Name
        End If
    Next

    fuzzymatch = ss
End Function

额外优化说明 #

你原有代码中每次循环都会重复计算总行数，修改后只计算一次，15000行场景下可以减少不必要的性能消耗。如果需要进一步提速，可以把单元格读取操作改成数组批量处理，能减少VBA和Excel单元格交互的耗时。

内容的提问来源于stack exchange，提问作者Dekamco