VBA Progress Indicator within a nextrow loop

H

haffy311

Board Regular
Joined
Jan 20, 2011
Messages
84
Hello all,

Looking for help to add a userform pop-up status indicator

My current code that runs is below and I would like a user form to pop up and actively tell me the % complete

% complete is found by simple division = count of non empty cells in column Q / count of non empty cells in column A


Sub CopyCells()


Application.ScreenUpdating = False


Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim x As Long
For x = 2 To LastRow

NextRow = Sheets("Data Entry").Range("A" & Rows.Count).End(xlUp).Row


Sheets("Mass_concept").Range("A" & x & ":P" & x).Copy
Sheets("Data Entry").Select
Sheets("Data Entry").Range("A" & NextRow).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False
Sheets("data").Select
Sheets("data").Range("F3:K3").Copy
Sheets("Mass_concept").Select
Sheets("Mass_concept").Range("Q" & x).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False

Next x

Application.ScreenUpdating = True



End Sub
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
Here's what I use. I can't post the form itself, so I'll just list its controls -- there are only four. Keep in mind you might have a problem because of turning off ScreenUpdating.
- Two labels called lblMajor and lblMinor; lblMajor has bold font.
- A progress bar called pbrProgress, which is in MSCOMCTL = Microsoft Windows Common Controls 6.0 (SP6)
- A text box called lblPercentage.

So at the beginning you load and show the form and use SetMaximum to set it as LastRow, and in your loop you use SetValue to each row's number (x).

Code: 
Option Explicit


' This implements a simple progress bar that shows two labels and percentage complete.
' It allows setting the title and both strings any time the value changes.


' STARTUP


Private Sub UserForm_Initialize()

    With Me.pbrProgress

        .Min = 0!
        .Max = 100!

        Me.SetValue .Min                        ' Sets up the percent too

    End With

End Sub


' KEYSTROKE EVENTS: Esc closes it


Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

    If KeyAscii = vbKeyEscape Then Unload Me

End Sub


' PROJECT-AVAILABLE ROUTINES: these set the min, max and value, adjusting when necessary


Friend Sub SetValue(NewValue As Single, Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)

    With Me.pbrProgress
    
        If NewValue < .Min Then .Min = NewValue
        If NewValue > .Max Then .Max = NewValue

        .Value = NewValue

    End With

    Call CalcPercentage(Title, Major, Minor)

End Sub


Friend Sub SetMinimum(NewMin As Single, Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)

    With Me.pbrProgress

        If NewMin > .Max Then .Max = NewMin
        If NewMin > .Value Then .Value = NewMin
        
        .Min = NewMin

    End With

    Call CalcPercentage(Title, Major, Minor)
End Sub


Friend Sub SetMaximum(NewMax As Single, Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)

    With Me.pbrProgress
        If NewMax < .Min Then .Min = NewMax
        If NewMax < .Value Then .Value = NewMax
        
        .Max = NewMax
    End With
    Call CalcPercentage(Title, Major, Minor)
End Sub


Friend Sub SetStrings(Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)
    If Title <> vbNullString Then Me.Caption = Title: DoEvents
    If Minor <> vbNullString Then Me.lblMinor.Caption = Minor: DoEvents
    If Major <> vbNullString Then Me.lblMajor.Caption = Major: DoEvents
End Sub


' PRIVATE ROUTINES


Private Sub CalcPercentage(Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)
    With Me.pbrProgress
        Me.lblPercentage.Caption = Format$((.Value - .Min) / (.Max - .Min), "0.0%"): DoEvents
    End With
    Call SetStrings(Title, Major, Minor)

End Sub
 
Upvote 0
The status bar continues to update when ScreenUpdating set to false


Test this simple macro by inserting it in a new workbook and running it from the worksheet (not from iinside VBA window)
- it writes data to a worksheet (to give it something to do and to provide the % complete)
- Status Bar (see bottom left of screen) shows ongoing status
Code: 
Sub UpdateStatusBar()
    Dim OldStatusBar, K As Long
    With Application
        .ScreenUpdating = False
        OldStatusBar = .DisplayStatusBar
        .DisplayStatusBar = True
        Range("A1:A50000").ClearContents
            For K = 1 To 50000
                Cells(K, 1) = WorksheetFunction.CountA(Range("A1:A50000")) / 500
                If K Mod 500 = 0 Then .StatusBar = Round(Cells(K, 1), 0) & " %"
            Next
        .StatusBar = False
    .DisplayStatusBar = OldStatusBar
    End With
End Sub
 
Last edited:
Upvote 0
thank you i will try this out


jjasmith4 said:
Here's what I use. I can't post the form itself, so I'll just list its controls -- there are only four. Keep in mind you might have a problem because of turning off ScreenUpdating.
- Two labels called lblMajor and lblMinor; lblMajor has bold font.
- A progress bar called pbrProgress, which is in MSCOMCTL = Microsoft Windows Common Controls 6.0 (SP6)
- A text box called lblPercentage.

So at the beginning you load and show the form and use SetMaximum to set it as LastRow, and in your loop you use SetValue to each row's number (x).

Code: 
Option Explicit


' This implements a simple progress bar that shows two labels and percentage complete.
' It allows setting the title and both strings any time the value changes.


' STARTUP


Private Sub UserForm_Initialize()

    With Me.pbrProgress

        .Min = 0!
        .Max = 100!

        Me.SetValue .Min                        ' Sets up the percent too

    End With

End Sub


' KEYSTROKE EVENTS: Esc closes it


Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

    If KeyAscii = vbKeyEscape Then Unload Me

End Sub


' PROJECT-AVAILABLE ROUTINES: these set the min, max and value, adjusting when necessary


Friend Sub SetValue(NewValue As Single, Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)

    With Me.pbrProgress
    
        If NewValue < .Min Then .Min = NewValue
        If NewValue > .Max Then .Max = NewValue

        .Value = NewValue

    End With

    Call CalcPercentage(Title, Major, Minor)

End Sub


Friend Sub SetMinimum(NewMin As Single, Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)

    With Me.pbrProgress

        If NewMin > .Max Then .Max = NewMin
        If NewMin > .Value Then .Value = NewMin
        
        .Min = NewMin

    End With

    Call CalcPercentage(Title, Major, Minor)
End Sub


Friend Sub SetMaximum(NewMax As Single, Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)

    With Me.pbrProgress
        If NewMax < .Min Then .Min = NewMax
        If NewMax < .Value Then .Value = NewMax
        
        .Max = NewMax
    End With
    Call CalcPercentage(Title, Major, Minor)
End Sub


Friend Sub SetStrings(Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)
    If Title <> vbNullString Then Me.Caption = Title: DoEvents
    If Minor <> vbNullString Then Me.lblMinor.Caption = Minor: DoEvents
    If Major <> vbNullString Then Me.lblMajor.Caption = Major: DoEvents
End Sub


' PRIVATE ROUTINES


Private Sub CalcPercentage(Optional Title As String = vbNullString, Optional Major As String = vbNullString, Optional Minor As String = vbNullString)
    With Me.pbrProgress
        Me.lblPercentage.Caption = Format$((.Value - .Min) / (.Max - .Min), "0.0%"): DoEvents
    End With
    Call SetStrings(Title, Major, Minor)

End Sub
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
How to automatically paste the data from one sheet to another using VBA
Replies
4
Views
182
Alex Blakenburg
A
willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
244
willow1985
willow1985
F
  • Solved
How to make loop stop when the cell is empty? (VBA)
Replies
3
Views
281
kvsrinivasamurthy
K
K
  • Question Question
Increasing row before the macro runs again
Replies
1
Views
185
kbk
K
brent3162
  • Solved
VBA help with increasing row before macro runs again.
Replies
3
Views
343
jolivanes
jolivanes

Forum statistics

Threads
1,223,214
Messages
6,170,772
Members
452,353
Latest member
strainu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top