VBA - Show Progress Bar While Macro Executes

Question

I have a macro that opens xlsx files in a folder one at a time and copies their sheets into a specific file. Sometimes this macro takes rather long to run and I would like to add a progress bar to show the user how far along the macro is.

I found a few guides that show how to do this, and I tested them in sample workbooks. Now, I am trying to integrate the guides with my macro but I am not having any success.

Here is my code (to copy the sheets):

Sub ImportDataSheets()

    Dim X As Workbook
    Set X = Workbooks("3rd Party.xlsm")

    path = "X:\Test\3rd Party\\"
    Filename = Dir(path & "*.xlsx")

    Do While Filename <> ""
        Workbooks.Open Filename:=path & Filename, ReadOnly:=True

        For Each Sheet In ActiveWorkbook.Sheets

            Sheet.Copy After:=X.Sheets(1)

        Next Sheet

        Workbooks(Filename).Close
        Filename = Dir()

    Loop

End Sub

Here is the link to the guide for using a form as a progress bar:

http://spreadsheetpage.com/index.php/tip/displaying_a_progress_indicator/

Here is the basic breakdown of that guide:

1) Insert form and make it look like this:

Added a frame (renamed to FrameProgress) inside the form and a label (renamed to LabelProgress) inside the frame

2) Right click on the form and click on view code

3) Inside the window, add this code:

Private Sub UserForm_activate()
    Call Main
End Sub

4) Insert a module and add this code:

Sub Main()
'   Inserts random numbers on the active worksheet
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim r As Integer, c As Integer
    Dim PctDone As Single

    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    Cells.Clear
    Application.ScreenUpdating = False
    Counter = 1
    RowMax = 100
    ColMax = 25
    For r = 1 To RowMax
        For c = 1 To ColMax
            Cells(r, c) = Int(Rnd * 1000)
            Counter = Counter + 1
        Next c
        PctDone = Counter / (RowMax * ColMax)
        With UserForm1
            .FrameProgress.Caption = Format(PctDone, "0%")
            .LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
        End With
'       The DoEvents statement is responsible for the form updating
        DoEvents
    Next r
    Unload UserForm1
End Sub

5) Insert a module and add this code:

Sub ShowDialog()
    UserForm1.LabelProgress.Width = 0
    UserForm1.Show
End Sub

6) Run the "ShowDialog" module and it will fill data from cell A1 - cell Y100 and display a progress bar while doing so - This works 100%

I noticed in the above code, there's a counter and that counter gets used to divide by the row and column count combined to get the percentage, so I got the below code to do a count of the files in the folder so that I would have a counter value - and after every file gets closed, the second count variable would increment by 1.

Here is where I got the code for the counter:

count files in specific folder and display the number into 1 cel

Code:

Sub sample()

    Dim FolderPath As String, path As String, count As Integer
    FolderPath = "X:\Test\3rd Party"

    path = FolderPath & "\*.xlsx"

    Filename = Dir(path)

    Do While Filename <> ""
       count = count + 1
        Filename = Dir()
    Loop

    Range("Q8").Value = count
    'MsgBox count & " : files found in folder"
End Sub

Now here is where and/how I have tried to "combine" my code with the guide:

1) This is what the code in my form looks like:

Sub UserForm_activate()
    Call testing
End Sub

2) This is what my sub looked like:

Sub testing()

    Dim FolderPath As String, path As String, count As Integer
    Dim PctDone As Single
    Dim Counter As Integer
    FolderPath = "X:\Test\3rd Party"

    path = FolderPath & "\*.xlsx"

    Dim X As Workbook
    Set X = Workbooks("3rd Party.xlsm")

    Counter = 1

    Filename = Dir(path)

    For r = 1 To count

        Do While Filename <> ""

            Workbooks.Open Filename:=path & Filename, ReadOnly:=True

            For Each Sheet In ActiveWorkbook.Sheets

                Sheet.Copy After:=X.Sheets(1)

                Workbooks(Filename).Close

                Filename = Dir()

            Next Sheet

            count = count + 1

        Loop

        PctDone = Counter / count

        With UserForm1

            .FrameProgress.Caption = Format(PctDone, "0%")
            .LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)

        End With

        DoEvents

    Next r

    Unload UserForm1

End Sub

I have many macros, and it would be fantastic to use this with the ones that take long to execute, so I am hoping that if I get it to work with one, I can use it with them all.

Answer 1

Hope it helps ..

Edit : I moved outside for each loop the lines :

   Workbooks(strFile).Activate
   ActiveWorkbook.Close SaveChanges:=False

The code :

 Sub testing()

    Application.ScreenUpdating = False
    Dim path As String, count As Integer
    Dim PctDone As Single
    Dim Counter As Integer
    count = 0

    Dim wkbk As Workbook
    Set wkbk = Workbooks("3rd Party.xlsm")

    'Change this to your folder path
    path = "X:\Test\3rd Party\"
    strFile = Dir(path & "*.xlsx")

    'This loop counts the number of files in my folder
    Do While Len(strFile) > 0
        count = count + 1
        strFile = Dir
    Loop

    strFile = Dir(path & "\*.xlsx")
    ' This loop will go through the folder and open each file and close it
    Do While Len(strFile) > 0

        Workbooks.Open Filename:=path & "\" & strFile, ReadOnly:=False
        Workbooks(strFile).Activate
        ''''' Do what you want Here '''''

        For Each Sheet In ActiveWorkbook.Sheets

            Sheet.Copy After:=wkbk.Sheets(1)

        Next Sheet

        Workbooks(strFile).Activate
        ActiveWorkbook.Close SaveChanges:=False

        'Every time it opens a file and close it, the counter will increment by one
        Counter = Counter + 1

        'The progress bar will be updated each time a new file is opened
        PctDone = Counter / count
        With UserForm1
            .FrameProgress.Caption = Format(PctDone, "0%")
            .LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
        End With

        DoEvents

        'Go to the next file in the folder
        strFile = Dir
    Loop
    Application.ScreenUpdating = True

    Unload UserForm1

End Sub

Answer 2

Using the example for a progress bar that I gave in this post.

Notice Option Explicit at the very top of the module.... I can't stress enough how important this is. It forces you to declare each variable before using it.

Option Explicit

Sub ImportDataSheets()

    Dim X As Workbook
    Dim Src_Book As Workbook
    Dim FileCount As Long

    Dim Path As String
    Dim FileName As String
    Dim Sheet As Worksheet

    Dim lCurrentCount As Long

    Set X = Workbooks("3rd Party.xlsm")

    Path = "X:\Test\3rd Party\\"
    FileName = Dir(Path & "*.xlsx")

    'This will count all files in the folder.
    FileCount = CreateObject("Scripting.FileSystemObject").GetFolder(Path).Files.Count

    Do While FileName <> ""
        Set Src_Book = Workbooks.Open(FileName:=Path & FileName, ReadOnly:=True)

        For Each Sheet In Src_Book.Sheets
            Sheet.Copy After:=X.Sheets(1)
        Next Sheet

        'This is where the progress bar gets updated.  
        'You'll need something to update the lCurrentCount for each book.
        UpdateProgressBar lCurrentCount, lFinalCount

        Src_Book.Close
        FileName = Dir()
    Loop

End Sub  

You could change UpdateProgressBar lCurrentCount, lFinalCount to UpdateProgressBar lCurrentCount, lFinalCount, Src_Book.Name so the progress bar displays the name of the book being opened as well.