如何结合我的VBA工作进度条？

我想参考这个进度条示例。 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 

我读了进度条码。 它需要使用循环variablesPctDone = Counter / (RowMax * ColMax) 。 对于我的代码，它包括不同的工作 – SQL计算，粘贴在工作表（“报告”），应付工作表（“报告”）到新的工作簿。因此，我不知道如何适合我的代码与此进度条应用程序。

参考VBA Excel中的进度条

---

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

Answer 1

您无需使用进度条本身，因为您无法计算完成的工作百分比。 在这种情况下，最好让用户知道你（或者代码在做什么）。 你可以使用Application.StatusBar来更新，但我们有多less人真的在那里看？ 另外，除了popup窗体并更新状态之外，没有什么更多的function可以使用。如果需要，也可以在用户窗体上使用animationGIFS 。

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

好吧你永远不会在UserForm_Initialize()事件中显示进度。 显示进程实际启动时的进度。 如果需要，将所有内容移到UserForm_Activate()或单击Commandbutton 。 我正在使用UserForm_Click()进行演示。

比方说，我们有一个用户窗体，看起来像下面的Frame和列表框控件。

把这个代码放在用户表单中

 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. 在开始任何过程之前，将说明添加到列表框中。 我在上面的代码中添加了示例stream程和描述。 请修改它们以满足您的需求。
2. 注意行ListBox1.Selected(ListBox1.ListCount - 1) = True ？ 这将确保总是select最近的最多条目。 这也确保列表框滚动到最新的条目，如果有很多事情被添加到列表框。

在行动

编辑

你误解了它是如何工作的:)

1. 在表单上添加一个列表框，如上图所示。
2. 删除用户表单中的所有代码，并用此代码replace它

现在运行代码。

 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