VBA Progress Indicator within a nextrow loop

[haffy311]

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

 

[jjasmith4]

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).

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

 

[Yongle]

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

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

 

[haffy311]

thank you i will try this out

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).

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

 

[haffy311]

okay, thank you. yes, this works in a new worksheet.