进度栏以显示完成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 :)

Answer 1

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

Answer 2

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