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?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

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
NorieAnalyst Assistant Commented:
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
Martin LissOlder than dirtCommented:
I'm attaching a workbook that contains a working progress bar.
Progress-Bar.xls
1
Discover the Answer to Productive IT

Discover app within WatchGuard's Wi-Fi Cloud helps you optimize W-Fi user experience with the most complete set of visibility, troubleshooting, and network health features. Quickly pinpointing network problems will lead to more happy users and most importantly, productive IT.

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 FyeOwner, Developing Solutions LLCCommented:
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 FyeOwner, Developing Solutions LLCCommented:
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
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
NorieAnalyst Assistant Commented:
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
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Programming

From novice to tech pro — start learning today.