VBA ProgressBar

Hi All

I need guidance with setting up a ProgressBar in the VBA I built, see below (I have removed the IP, DB and Credentials in the connection string for security reasons)

Option Explicit

Public Const connStr = "Provider=SQLOLEDB.1;Data Source=IP;Initial Catalog=TunnelCosmos;User ID=User;Password=Password;Persist Security Info=True;"
Sub RunReport()

    
    'stop screen refresh
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
    
    End With
    
    
    Sheets("Output").Activate
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A2").Select
    
    ' End If
    
    ' Variables
    
    Dim cn         As ADODB.Connection
    Dim cmd        As ADODB.Command
    Dim rs         As ADODB.RecordSet
    Dim strSQL     As String
    'Declare the ProgressBar Object
    Dim MyProgressbar As ProgressBar
    'Initialize a New Instance of the Progressbars
    Set MyProgressbar = New ProgressBar
    
    


    ' Status
    '''''''''''''''''''''''''''''''
    
        'MyProgressbar.TotalActions = 100
        With MyProgressbar
        'Set the Title
        .Title = "Computing"
        'Set this to true if you want to update
        'Excel's Status Bar Also
        .ExcelStatusBar = True
        'Set the colour of the bar in the Beginning
        .StartColour = rgbMediumSeaGreen
        'Set the colour of the bar at the end
        .EndColou = rgbGreen
        End With
        
        
        




    '''''''''''''''''''''''''''''''

    
    Set cn = New ADODB.Connection
    cn.ConnectionString = connStr
    cn.Open
    
    Set cmd = New ADODB.Command

    With cmd
            .ActiveConnection = cn
            .CommandText = "Siriusware_Report_BookingsWhereHear"
            .CommandType = adCmdStoredProc
            .Parameters.Append cmd.CreateParameter("startdate", adDBDate, adParamInput, 120)
            .Parameters("startdate").value = Sheets("Parameters").Range("Start_Date").value
            .Parameters.Append cmd.CreateParameter("enddate", adDBDate, adParamInput, 120)
            .Parameters("enddate").value = Sheets("Parameters").Range("End_Date").value
            ' .Parameters.Append cmd.CreateParameter("facility", adVarChar, adParamInput, 120)
            ' .Parameters("facility").Value = Sheets("Parameters").Range("Facility").Value
            ' .Execute
            .CommandTimeout = 600
        End With
        
    Set rs = cmd.Execute()
    
    Sheets("Output").Range("A2").CopyFromRecordset rs
    
    ' Sheets("Output").Range("A2").Select
    
    rs.Close
    Set cmd = Nothing
    
    cn.Close
    
End Sub

Open in new window


What I'm trying to achieve here is when the Macro is run (assigned to a button for the user to click), a progress bar pops up that shows the percentage with a title "Computing". At the moment, when running the macro using the VBA code above, I cannot see the Progress Bar. I'm sure there is something here I did not set correct.

In the VBA Project Explorer, you will see Forms>ProgressBar, you will also see Module>Report (this holds the VBA code, see above). Attached is a file called Progress where it shows the Forms and Modules. Additionally, the ProgressBar was obtained from a file downloaded from the net (sorry, I don't have the source but will share it when I find it).

Any help is greatly appreciated!
Stevie ZakhourAsked:
Who is Participating?
 
Martin LissOlder than dirtCommented:
You misunderstood how I was suggesting that the userform be used. The For x = 1 To 300000 loop in my code was only there to simulate a long-running process. In the code below the userform is shown at the start of what I believe to be is your long-running process, and it is closed at the end of it.

Option Explicit

Public Const connStr = "Provider=SQLOLEDB.1;Data Source=IP;Initial Catalog=DB;User ID=User;Password=Password;Persist Security Info=True;"
Sub RunReport()
    
    'Stop Screen Refresh
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
    
    End With
    
    Sheets("DataDump").Activate
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A2").Select
    
    ' Variables
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim cn         As ADODB.Connection
    Dim cmd        As ADODB.Command
    Dim rs         As ADODB.Recordset
    Dim strSQL     As String
    Dim i As Long
    Dim x As Long
    Dim PvtTbl As PivotTable
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    
        'Status for End User
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Show the userform at the start of the long-running process
    Application.Cursor = xlWait
    UserForm1.MousePointer = fmMousePointerHourGlass

    UserForm1.Show vbModeless

    '''''''''''''''''''''''''''''''''''''''''''''''''''

    
    Set cn = New ADODB.Connection
    cn.ConnectionString = connStr
    cn.Open
    
    Set cmd = New ADODB.Command

    With cmd
            .ActiveConnection = cn
            .CommandText = "Siriusware_Report_BookingsWhereHear"
            .CommandType = adCmdStoredProc
            .Parameters.Append cmd.CreateParameter("startdate", adDBDate, adParamInput, 120)
            .Parameters("startdate").Value = Sheets("Parameters").Range("Start_Date").Value
            .Parameters.Append cmd.CreateParameter("enddate", adDBDate, adParamInput, 120)
            .Parameters("enddate").Value = Sheets("Parameters").Range("End_Date").Value
            .CommandTimeout = 600
        End With
        
    Set rs = cmd.Execute()
    
    Sheets("DataDump").Range("A2").CopyFromRecordset rs
    
        ' Update Pivot
    '''''''''''''''''''''''''''''''
        Cells.EntireColumn.AutoFit
        For Each PvtTbl In Worksheets("Parameters").PivotTables
        PvtTbl.RefreshTable
        Next
    '''''''''''''''''''''''''''''''
        
    rs.Close
    Set cmd = Nothing
    
    cn.Close
    
    ' Close the uerform when done with the process
    Unload UserForm1

    UserForm1.MousePointer = fmMousePointerDefault
    Application.Cursor = xlDefault
    
End Sub

Open in new window

0
 
Martin LissOlder than dirtCommented:
Does your code compile? In the IDE->Debug->Compile VBAProject.

Also note that if you meant to attach your workbook, you didn't.
1
 
NorieVBA ExpertCommented:
Stevie

Do you want the progress bar to show, well, the progress of the query you are executing?

If you do I don't think that's going to be possible.

As soon as you start the query your code loses 'focus' so you wouldn't be able to update the progress bar,
1
WEBINAR: 10 Easy Ways to Lose a Password

Join us on June 27th at 8 am PDT to learn about the methods that hackers use to lift real, working credentials from even the most security-savvy employees. We'll cover the importance of multi-factor authentication and how these solutions can better protect your business!

 
Martin LissOlder than dirtCommented:
I'm attaching a workbook that contains a working progress bar.
Progress-Bar.xls
1
 
Stevie ZakhourAuthor Commented:
Hi Norie

Correct, and I see. Is there any sort of status bar to let the end user know the spreadsheet is processing their request?

Thanks to all who have commented!
0
 
Martin LissOlder than dirtCommented:
A userform shown vbmodeless that says "Working..." could be displayed along with the use of the hourglass cursor,
1
 
Stevie ZakhourAuthor Commented:
Thanks Martin, that sounds promising. Where would I be able to obtain the code?

Thanks again
0
 
Martin LissOlder than dirtCommented:
Here's a demo.
29093812.xlsm
1
 
Stevie ZakhourAuthor Commented:
Thanks Martin, looks great. I will test and will revert back.

Thanks again to all!
0
 
Dale FyeCommented:
you might also want to take a look at my article on progress bars, written for Access but could easily be ported to an Excel UserForm.
1
 
Stevie ZakhourAuthor Commented:
Hi All

Thanks again for your help, really appreciate it. Below is the modified and final VBA code

Option Explicit

Public Const connStr = "Provider=SQLOLEDB.1;Data Source=IP;Initial Catalog=DB;User ID=User;Password=Password;Persist Security Info=True;"
Sub RunReport()
    
    'Stop Screen Refresh
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
    
    End With
    
    Sheets("DataDump").Activate
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A2").Select
    
    ' Variables
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim cn         As ADODB.Connection
    Dim cmd        As ADODB.Command
    Dim rs         As ADODB.RecordSet
    Dim strSQL     As String
    Dim i As Long
    Dim x As Long
    Dim PvtTbl As pivotTable
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    
        'Status for End User
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    Application.Cursor = xlWait
    UserForm1.MousePointer = fmMousePointerHourGlass

    UserForm1.Show vbModeless
    For x = 1 To 300000
    DoEvents
    x = x
    Next
    Unload UserForm1

    UserForm1.MousePointer = fmMousePointerDefault
    Application.Cursor = xlDefault
    '''''''''''''''''''''''''''''''''''''''''''''''''''

    
    Set cn = New ADODB.Connection
    cn.ConnectionString = connStr
    cn.Open
    
    Set cmd = New ADODB.Command

    With cmd
            .ActiveConnection = cn
            .CommandText = "Siriusware_Report_BookingsWhereHear"
            .CommandType = adCmdStoredProc
            .Parameters.Append cmd.CreateParameter("startdate", adDBDate, adParamInput, 120)
            .Parameters("startdate").value = Sheets("Parameters").Range("Start_Date").value
            .Parameters.Append cmd.CreateParameter("enddate", adDBDate, adParamInput, 120)
            .Parameters("enddate").value = Sheets("Parameters").Range("End_Date").value
            .CommandTimeout = 600
        End With
        
    Set rs = cmd.Execute()
    
    Sheets("DataDump").Range("A2").CopyFromRecordset rs
    
        ' Update Pivot
    '''''''''''''''''''''''''''''''
        Cells.EntireColumn.AutoFit
        For Each PvtTbl In Worksheets("Parameters").PivotTables
        PvtTbl.RefreshTable
        Next
    '''''''''''''''''''''''''''''''
        
    rs.Close
    Set cmd = Nothing
    
    cn.Close
    
End Sub

Open in new window


I compiled the VBA project with no reported issues. The output is in the attached called Computing. Let me know if you think we can modify the VBA code further to make it more streamlined or efficient.
Computing.pdf
0
 
Dale FyeCommented:
not quite sure why you are unloading the userform before you execute the CopyFromRecordset method, but other than that, it looks fine to me.

You will not be able to do a true "progress bar" using CopyFromRecordset, because it gives you no way of determining what percentage of the operation is complete.  The only way to do that would be to loop through the recordset and push each record into the spreadsheet, one record at a time, which would likely be significantly slower than CopyFromRecordset.  However, with this method, you could display some form of progress bar (box) that has a width based on the percentage of the recordset which has been written to the spreadsheet.
1
 
NorieVBA ExpertCommented:
Is this the part of the code you want the progress bar for?
For Each PvtTbl In Worksheets("Parameters").PivotTables
    PvtTbl.RefreshTable
Next

Open in new window

1
 
Stevie ZakhourAuthor Commented:
Hi All

I apologize for the delayed response.

Thank you very much for your support, I'm happy with the way the spreadsheet after using your recommendations.

Thanks again!
0
 
Martin LissOlder than dirtCommented:
You’re welcome and I’m glad I was able to help.

If you expand the “Full Biography” section of my profile you’ll find links to some articles I’ve written that may interest you.

Marty - Microsoft MVP 2009 to 2017
              Experts Exchange Most Valuable Expert (MVE) 2015, 2017
              Experts Exchange Top Expert Visual Basic Classic 2012 to 2017
              Experts Exchange Top Expert VBA (current)
1
 
Stevie ZakhourAuthor Commented:
Thanks Martin, appreciate it!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.