How to combine my vba working with a progress bar?

Question

I want to reference to this progress bar sample . http://spreadsheetpage.com/index.php/tip/displaying_a_progress_indicator/

About my vb working ,I m going to generate a report that using ADO in entire worksheet . As the report generation time is too long (1 min) , I want to implement a progress bar during the report generation .Btw , the report will be produced in a new excel file .

 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

I read the progress bar codes . It needs to use the loop variable PctDone = Counter / (RowMax * ColMax). For my codes , it includes different works- SQL calculation , pasting on worksheets("report") , coping worksheets("report") to new workbook .Hence , I don't know how to fit my code with this progress bar application .

Reference to Progress bar in VBA Excel

---

If it is impossible to implement progress bar in my case , what can i do tho let the user know "Be patient to wait about 1 min "?

Answer 1

You do not need to use a progress bar per se as you can't calculate the percentage of work done. In such a case, it is better to let the user know of what you(or the code is doing). You could use Application.StatusBar to update but how many of us actually look down there? Also there's nothing more fancy than a form popping up and updating you about the status... You can also use Animated GIFS on the userform if you want.

I tried to use a userform that showing "Please wait one minute` But i find that it need to spend some times on loading the new userform . That makes the whole application much loading time

Ok You never show progress in the UserForm_Initialize() event of the userform. Show the progress when the process actually starts. If required, move everything to UserForm_Activate() or in a click of a Commandbutton. I am using UserForm_Click() for demonstration purpose.

Let's say we have a userform which looks like below with a Frame and Listbox` control.

Put this code in the userform

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

Logic:

1. Before starting any process, add the description to the listbox. I have added sample processes and descriptions in the above code. Please amend them to suit your needs.
2. Notice the line ListBox1.Selected(ListBox1.ListCount - 1) = True? This will ensure that the recent most entry is always selected. This also ensure that the Listbox scrolls to the latest entry if many things are added to the listbox.

In Action

EDIT

You have misunderstood how it works :)

1. Add a listbox on the form as shown in the image above.
2. Delete all code from the userform and replace it with this code

Now run the code.

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