Help to adding progress bar to code

[nhnn1986]

Hi all

I have code belove in sheets(A) and work well

Private Sub Worksheet_Change(ByVal Target As Range)Dim rngB As Range, rngC As Range, cel As Range
Dim wksB As Worksheet, wksC As Worksheet, wksD As Worksheet
Dim lngRowB As Long, lngRowC As Long, lngRowD As Long, lngRowsCopied As Long


    If Target.Address = "$A$1" Then
        If Len(Trim(Target.Value)) = 4 Then
            
            Set wksB = ThisWorkbook.Worksheets("B")
            Set wksC = ThisWorkbook.Worksheets("C")
            Set wksD = ThisWorkbook.Worksheets("D")
            wksD.Cells.Clear
            
            lngRowB = wksB.Range("A" & Rows.Count).End(xlUp).Row
            lngRowC = wksC.Range("A" & Rows.Count).End(xlUp).Row
            lngRowD = wksD.Range("A" & Rows.Count).End(xlUp).Row
            
            Set rngB = wksB.Range("A1:A" & lngRowB)
            Set rngC = wksC.Range("A1:A" & lngRowC)
            
            lngRowsCopied = 0
            
            For Each cel In rngB
                If InStr(1, "-" & cel.Value, Target.Value, vbTextCompare) > 0 Then
                    lngRowD = lngRowD + 1
                    cel.EntireRow.Copy Destination:=wksD.Cells(lngRowD, 1)
                    lngRowsCopied = lngRowsCopied + 1
                End If
                Application.StatusBar = "Processing sheet B: " & Format(cel.Row / rngB.Rows.Count, "0%") & "  Rows copied = " & lngRowsCopied
            Next cel
            lngRowsCopied = 0
            For Each cel In rngC
                If InStr(1, "-" & cel.Value, Target.Value, vbTextCompare) > 0 Then
                    lngRowD = lngRowD + 1
                    cel.EntireRow.Copy Destination:=wksD.Cells(lngRowD, 1)
                    lngRowsCopied = lngRowsCopied + 1
                End If
                Application.StatusBar = "Processing sheet C: " & Format(cel.Row / rngC.Rows.Count, "0%") & "  Rows copied = " & lngRowsCopied
            Next cel
        Else
            MsgBox ("Enter a valid 4-digit year.")
        End If
                
    End If
    
    Application.StatusBar = False


End Sub

Now i want appear progress bar like this whrn run code:

Please help me.

 

[DanteAmor]

Your process would be faster if you filter the column for the year and copies the filtered range.
But anyway, I show you the code for porgressbar.


Create a userform with 5 labels, named: label1, label2, label3, lblRemain and lblDone.


Put the following code in the userform

Public ufTarget 'This statement goes to the top of the code


Private Sub UserForm_Activate()
    Label2.Caption = 1
    Call Main
End Sub


'
Sub Main()
' PROGRESS BAR CODES
    Dim rngB As Range, rngC As Range, cel As Range
    Dim wksB As Worksheet, wksC As Worksheet, wksD As Worksheet
    Dim lngRowB As Long, lngRowC As Long, lngRowD As Long, lngRowsCopied As Long
    Dim i As Long, tot As Long
    
    Set wksB = ThisWorkbook.Worksheets("B")
    Set wksC = ThisWorkbook.Worksheets("C")
    Set wksD = ThisWorkbook.Worksheets("D")
    wksD.Cells.Clear
    
    lngRowB = wksB.Range("A" & Rows.Count).End(xlUp).Row
    lngRowC = wksC.Range("A" & Rows.Count).End(xlUp).Row
    lngRowD = wksD.Range("A" & Rows.Count).End(xlUp).Row
    
    Set rngB = wksB.Range("A1:A" & lngRowB)
    Set rngC = wksC.Range("A1:A" & lngRowC)
    
    lngRowsCopied = 0
    
    i = 1
    tot = rngB.Rows.Count + rngC.Rows.Count
    Label3.Caption = "Of " & tot
    For Each cel In rngB
        If InStr(1, "-" & cel.Value, ufTarget, vbTextCompare) > 0 Then
            lngRowD = lngRowD + 1
            cel.EntireRow.Copy Destination:=wksD.Cells(lngRowD, 1)
            lngRowsCopied = lngRowsCopied + 1
        End If
        Label2.Caption = i
        i = i + 1
        Call ProgressBar(i / tot)
    Next cel
    
    lngRowsCopied = 0
    For Each cel In rngC
        If InStr(1, "-" & cel.Value, ufTarget, vbTextCompare) > 0 Then
            lngRowD = lngRowD + 1
            cel.EntireRow.Copy Destination:=wksD.Cells(lngRowD, 1)
            lngRowsCopied = lngRowsCopied + 1
        End If
        Label2.Caption = i
        i = i + 1
        Call ProgressBar(i / tot)
    Next cel
End Sub
'
Sub ProgressBar(PctDone As Single)
    lblDone.Width = PctDone * (lblRemain.Width - 2)
    DoEvents
End Sub

The code in the events of your sheet:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$A$1" Then
        If Len(Trim(Target.Value)) = 4 Then
            With UserForm1
                .ufTarget = Target.Value
                .Show
            End With
        Else
            MsgBox ("Enter a valid 4-digit year.")
        End If
    End If
    Application.StatusBar = False
End Sub

My test file

https://www.dropbox.com/s/ajgdpl7icllxnri/progress bar.xlsm?dl=0

 

[nhnn1986]

Thanks for your resspon, there's small problem that form not auto unload after progress done

 

[DanteAmor]

It would only be necessary to add a line

Public ufTarget 'This statement goes to the top of the code


Private Sub UserForm_Activate()
    Label2.Caption = 1
    Call Main
End Sub


'
Sub Main()
' PROGRESS BAR CODES
    Dim rngB As Range, rngC As Range, cel As Range
    Dim wksB As Worksheet, wksC As Worksheet, wksD As Worksheet
    Dim lngRowB As Long, lngRowC As Long, lngRowD As Long, lngRowsCopied As Long
    Dim i As Long, tot As Long
    
    Set wksB = ThisWorkbook.Worksheets("B")
    Set wksC = ThisWorkbook.Worksheets("C")
    Set wksD = ThisWorkbook.Worksheets("D")
    wksD.Cells.Clear
    
    lngRowB = wksB.Range("A" & Rows.Count).End(xlUp).Row
    lngRowC = wksC.Range("A" & Rows.Count).End(xlUp).Row
    lngRowD = wksD.Range("A" & Rows.Count).End(xlUp).Row
    
    Set rngB = wksB.Range("A1:A" & lngRowB)
    Set rngC = wksC.Range("A1:A" & lngRowC)
    
    lngRowsCopied = 0
    
    i = 1
    tot = rngB.Rows.Count + rngC.Rows.Count
    Label3.Caption = "Of " & tot
    For Each cel In rngB
        If InStr(1, "-" & cel.Value, ufTarget, vbTextCompare) > 0 Then
            lngRowD = lngRowD + 1
            cel.EntireRow.Copy Destination:=wksD.Cells(lngRowD, 1)
            lngRowsCopied = lngRowsCopied + 1
        End If
        Label2.Caption = i
        i = i + 1
        Call ProgressBar(i / tot)
    Next cel
    
    lngRowsCopied = 0
    For Each cel In rngC
        If InStr(1, "-" & cel.Value, ufTarget, vbTextCompare) > 0 Then
            lngRowD = lngRowD + 1
            cel.EntireRow.Copy Destination:=wksD.Cells(lngRowD, 1)
            lngRowsCopied = lngRowsCopied + 1
        End If
        Label2.Caption = i
        i = i + 1
        Call ProgressBar(i / tot)
    Next cel

[SIZE=3][COLOR=#0000ff][B]    Unload Me[/B][/COLOR][/SIZE]
End Sub
'
Sub ProgressBar(PctDone As Single)
    lblDone.Width = PctDone * (lblRemain.Width - 2)
    DoEvents
End Sub

 

[nhnn1986]

Thanks DanteAmor again, progress bar work well

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.