如何将我的 vba 与进度条结合使用？

Question

我想参考这个进度条示例。 http://spreadsheetpage.com/index.php/tip/displaying_a_progress_indicator/

关于我的 vb 工作，我将生成一个在整个工作表中使用 ADO 的报告。由于报告生成时间太长（1分钟），我想在报告生成过程中实现一个进度条。顺便说一句，报告将在一个新的excel文件中生成。

 Private Sub CommandButton3_Click()



    Dim sSQLQry As String
    Dim ReturnArray

    Dim Conn As New ADODB.Connection
    Dim mrs As New ADODB.Recordset

    Dim DBPath As String, sconnect As String



    DBPath = ThisWorkbook.FullName


    sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';"
    Conn.Open sconnect

   sSQLSting = "..."

   Set rs = Conn.Execute(sSQLSting)

   j = 6

    Do While Not rs.EOF
with thisworkbook.worksheets("report")
.Cells(j, 1) = rs.Fields(0).Value
.Cells(j, 3) = rs.Fields(2).Value
.Cells(j, 4) = rs.Fields(3).Value
.Cells(j, 7) = rs.Fields(6).Value
End with 


 j = j + 1

  rs.MoveNext

Loop


rs.Close

Dim wb As Workbook
    Set wb = Workbooks.Add

    ThisWorkbook.Sheets("report").Copy Before:=wb.Sheets(1)

...copy Sheets("report") to wb ...

strFileName = "c:\Users\" & Environ("Username") & "\Desktop\" & ThisWorkbook.Sheets("report").Cells(1, 1) & ".xlsx"
'End With
wb.SaveAs strFileName

我阅读了进度条码。它需要使用循环变量PctDone = Counter / (RowMax * ColMax)。对于我的代码，它包括不同的工作——SQL 计算、粘贴到工作表（“报告”）、将工作表（“报告”）复制到新工作簿。因此，我不知道如何使我的代码与这个进度条应用程序相匹配。

参考 Progress bar in VBA Excel

---

如果在我的情况下无法实现进度条，我该怎么做才能让用户知道“请耐心等待大约 1 分钟”？

Answer 1

您本身不需要使用进度条，因为您无法计算已完成工作的百分比。在这种情况下，最好让用户知道您（或代码在做什么）。您可以使用Application.StatusBar 进行更新，但我们当中有多少人真正往下看？此外，没有什么比弹出一个表单并更新您的状态更有趣的了……如果您愿意，您也可以在用户表单上使用Animated GIFS。

我尝试使用显示“请稍等一分钟”的用户表单，但我发现它需要花费一些时间来加载新的用户表单。这使得整个应用程序的加载时间很长

好的，您永远不会在用户窗体的UserForm_Initialize() 事件中显示进度。显示进程实际开始时的进度。如果需要，将所有内容移至UserForm_Activate() 或单击Commandbutton。我使用UserForm_Click() 进行演示。

假设我们有一个如下所示的用户表单，带有 Frame 和 Listbox` 控件。

将此代码放入用户表单中

Private Sub UserForm_Click()
    ListBox1.AddItem "I am performing something in a loop..."
    ListBox1.Selected(ListBox1.ListCount - 1) = True

    For i = 1 To 10
        Wait 3
    Next i

    ListBox1.AddItem "I am now writing something to the workbook..."
    ListBox1.Selected(ListBox1.ListCount - 1) = True

    Range("A1").Value = "Sid"

    ListBox1.AddItem "I am performing something again in a loop..."
    ListBox1.Selected(ListBox1.ListCount - 1) = True

    For i = 1 To 10
        Wait 3
    Next i

    '
    '~~> And So on
    '
End Sub

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

逻辑：

1. 在开始任何进程之前，将描述添加到列表框中。我在上面的代码中添加了示例流程和描述。请根据您的需要修改它们。
2. 注意到ListBox1.Selected(ListBox1.ListCount - 1) = True这行了吗？这将确保始终选择最近的条目。如果列表框中添加了许多内容，这还可以确保列表框滚动到最新条目。

行动中

编辑

你误解了它的工作原理:)

1. 如上图所示在表单上添加一个列表框。
2. 从用户窗体中删除所有代码并用此代码替换它

现在运行代码。

Private Sub UserForm_Activate()
    ListBox1.AddItem "Generating random numbers..."
    ListBox1.Selected(ListBox1.ListCount - 1) = True
    DoEvents

    For i = 1 To 1000
        For j = 1 To 1000
            ThisWorkbook.Sheets("content").Cells(i, j) = Rnd
        Next
    Next

    ListBox1.AddItem "Copying and working with Content sheet..."
    ListBox1.Selected(ListBox1.ListCount - 1) = True
    DoEvents

    Row = ThisWorkbook.Sheets("content").Range("A" & Rows.Count).End(xlUp).Row

    Set wb = Workbooks.Add

    ThisWorkbook.Sheets("content").Copy Before:=wb.Sheets(1)

    wb.Sheets(1).Cells(Row, 1) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("A:A"))
    wb.Sheets(1).Cells(Row, 2) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("B:B"))
    wb.Sheets(1).Cells(Row, 3) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("C:C"))
    wb.Sheets(1).Cells(Row, 4) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("D:D"))
    wb.Sheets(1).Cells(Row, 5) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("E:E"))
    wb.Sheets(1).Cells(Row, 6) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("F:F"))
    wb.Sheets(1).Cells(Row, 7) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("G:G"))
    wb.Sheets(1).Cells(Row, 8) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("H:H"))
    wb.Sheets(1).Cells(Row, 9) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("I:I"))
    wb.Sheets(1).Cells(Row, 10) = Application.WorksheetFunction.Sum(wb.Sheets(1).Range("K:K"))

    ListBox1.AddItem "Saving File..."
    ListBox1.Selected(ListBox1.ListCount - 1) = True
    DoEvents

    strFileName = "c:\Users\" & Environ("Username") & "\Desktop\" & ThisWorkbook.Sheets("content").Cells(1, 1) & ".xlsx"

    wb.SaveAs strFileName
    ThisWorkbook.Sheets("content").Cells.Clear

    ListBox1.AddItem "Done!"
    ListBox1.Selected(ListBox1.ListCount - 1) = True
    DoEvents
End Sub