Progress Bar to show how much of the process is completed Excel vba

Question

I have written code to copy paste certain rows from one workbook to another. I want a progress bar to show me the progress of the job taking into account each row pasted. For example: If I have to copy-paste 10 rows, then once 1 row is pasted it should show: 10% completed.

This is a snippet of my code:

 Sub Automate_Estimate()

 Set Wb = ThisWorkbook                  

 MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")

    Set wkb = Workbooks.Open(MyFile, UpdateLinks:=0)

    Application.StatusBar = "Copying In progress..." & Cells(Rows.Count, 2).End(xlUp).Row & "% completed"

    Debug.Print MyFile, DestName

        Set rng = Sheets(SourceName).Range("C12:R12")
        rng.Copy

        Wb.Sheets(DestName).Cells(1, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Set rng = Sheets(SourceName).Range("C30:R30")
        rng.Copy

        Wb.Sheets(DestName).Cells(24, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Set rng = Sheets(SourceName).Range("C22:R22")
        rng.Copy

        Wb.Sheets(DestName).Cells(4, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Set rng = Sheets(SourceName).Range("C20:R20")
        rng.Copy

        Wb.Sheets(DestName).Cells(14, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Set rng = Sheets(SourceName).Range("C40:R40")
        rng.Copy

        Wb.Sheets(DestName).Cells(17, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Set rng = Sheets(SourceName).Range("C16:R16")
        rng.Copy

        Wb.Sheets(DestName).Cells(7, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Set rng = Sheets(SourceName).Range("C17:R17")
        rng.Copy

        Wb.Sheets(DestName).Cells(8, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Set rng = Sheets(SourceName).Range("C21:R21")
        rng.Copy

        Wb.Sheets(DestName).Cells(16, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Set rng = Sheets(SourceName).Range("C52:R52")
        rng.Copy

        Wb.Sheets(DestName).Cells(56, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Application.StatusBar = "Copying Is complete"

        wkb.Close
    End Sub

The progress bar code is after 'Set wkb' (After line 2). The data is being pasted from the 2nd column. Can somebody help me with this? Thanks :)

score 0 · Answer 1 · answered Jan 16 '18 at 09:42

0

You have to set the StatusBar after every Copy to show a new text.

You could define a small SubRoutine:

Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
    fromRange.Copy
    toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
    DoEvents
End Sub

Define a Constant that holds the number of steps and increase a variable after every step:

Sub Automate_Estimate()
    Const Steps = 10
    Dim completed As Double

    ' ... (Set your Wb stuff here)
    completed = 0
    Application.StatusBar = "Copying In progress..."

    Call CopyRange(Sheets(SourceName).Range("C12:R12"), Wb.Sheets(DestName).Cells(1, 2), completed)
    completed = completed + (100 / Steps)
    ' ... (Add all your copying here and increase completed after every step)
    Application.StatusBar = False

End Sub

answered Jan 16 '18 at 09:42

FunThomas

23,043
3
18
34

I tried what you suggested, but it's still not working. Called the subroutine in my main Sub like you mentioned. – shettyrish Jan 16 '18 at 10:25
I mean, there is no Progress bar visible. Sorry, I'm new to VBA. – shettyrish Jan 16 '18 at 10:45
Should be - I tested it and it shows up to me. You are aware that it's rather small at the bottom of the Excel window? See https://stackoverflow.com/a/12918056/7599798 – FunThomas Jan 16 '18 at 11:59
Yes I am aware of that. The progress bar shows "Copying in Progress..." but doesn't show the percentage completion. – shettyrish Jan 16 '18 at 17:48

score 0 · Answer 2 · answered Jan 16 '18 at 10:32

Updated code as suggested by @FunThomas

Second sub which is used to call

Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
fromRange.Copy
toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks:=False, Transpose:=False

Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% 
completed"
DoEvents
End Sub

This is the Main Sub

Sub Automate_Estimate()
Dim completed As Double

Set Wb = ThisWorkbook
Const steps = 9                                                            
'Number of rows copied



    MyFile = Application.GetOpenFilename(FileFilter:="Excel 
   Files,*.xl*;*.xm*")


    Set wkb = Workbooks.Open(MyFile, UpdateLinks:=0)

    completed = 0
    Application.StatusBar = "Copying In progress..."



        Call CopyRange(Sheets(SourceName).Range("C12:R12"), Wb.Sheets(DestName).Cells(1, 2), completed)
        completed = completed + (100 / steps)

        Call CopyRange(Sheets(SourceName).Range("C30:R30"), Wb.Sheets(DestName).Cells(24, 2), completed)
        completed = completed + (100 / steps)


        Call CopyRange(Sheets(SourceName).Range("C22:R22"), Wb.Sheets(DestName).Cells(4, 2), completed)
        completed = completed + (100 / steps)

        Call CopyRange(Sheets(SourceName).Range("C20:R20"), Wb.Sheets(DestName).Cells(14, 2), completed)
        completed = completed + (100 / steps)


        Call CopyRange(Sheets(SourceName).Range("C40:R40"), Wb.Sheets(DestName).Cells(17, 2), completed)
        completed = completed + (100 / steps)

        Call CopyRange(Sheets(SourceName).Range("C16:R16"), Wb.Sheets(DestName).Cells(7, 2), completed)
        completed = completed + (100 / steps)

        Call CopyRange(Sheets(SourceName).Range("C17:R17"), Wb.Sheets(DestName).Cells(8, 2), completed)
        completed = completed + (100 / steps)

        Call CopyRange(Sheets(SourceName).Range("C21:R21"), Wb.Sheets(DestName).Cells(16, 2), completed)
        completed = completed + (100 / steps)


        Call CopyRange(Sheets(SourceName).Range("C52:R52"), Wb.Sheets(DestName).Cells(56, 2), completed)
        completed = completed + (100 / steps)


        Application.StatusBar = False

        wkb.Close

    DoEvents
 End Sub

Progress Bar to show how much of the process is completed Excel vba

2 Answers2