Progress Bar

MelG

New Member
Joined
Jul 28, 2011
Messages
21
Hi, the code below is to import file names into excel from any given folder. I'd like to have a progress bar but I'm not sure how it would work. I thought if I could work out how many file names are going to be imported before the Macro does it's work, I could use it to do a progress bar showing percentage complete as every file name and path is loaded into the array. Any ideas? The code was not written by me so please go back to basics when replying.

Option Explicit
Dim cnt As Long

Sub ListFiles()
Dim objFSO As FileSystemObject
Dim MyPath As String
Dim MyArray() As String

cnt = 0

Set objFSO = CreateObject("Scripting.FileSystemObject")

Sheets.Add

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Select a Folder"
.Show
'Call UpdateProgressIndicator
If .SelectedItems.Count > 0 Then
MyPath = .SelectedItems(1)
Call ProcessFolders(objFSO, MyPath, MyArray)
Else
Exit Sub
End If
End With
Cells.Clear
If cnt > 0 Then
Range("A1:B1").Value = Array("File Path", "File Name")
Range("A2").Resize(UBound(MyArray, 2), UBound(MyArray, 1)).Value = WorksheetFunction.Transpose(MyArray)
Else
MsgBox "No files were found...", vbExclamation

End If


End Sub

Sub ProcessFolders(ByRef f, ByVal p, ByRef arr)
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Set objFolder = f.GetFolder(p)
For Each objFile In objFolder.Files
cnt = cnt + 1
ReDim Preserve arr(1 To 2, 1 To cnt)
arr(1, cnt) = objFolder.path
arr(2, cnt) = objFile.Name
Next objFile
For Each objSubFolder In objFolder.SubFolders
Call ProcessFolders(f, objSubFolder, arr)
Next objSubFolder
End Sub
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,999
You could use this function to count the number of files in the specified folder:

Code:
Function CountFiles(fso As FileSystemObject, folderPath As String) As Long

    Dim objFolder As folder
    Dim objSubFolder As folder
    
    Set objFolder = fso.GetFolder(folderPath)
    
    CountFiles = CountFiles + objFolder.Files.Count
    
    For Each objSubFolder In objFolder.SubFolders
        CountFiles = CountFiles + CountFiles(fso, objSubFolder.Path)
    Next
    
End Function
Call it like this:
Code:
filesTotal = CountFiles(objFSO, MyPath)
You would call UpdateProgressIndicator in the "For Each objFile In objFolder.Files" loop. Pass as parameters the total number of files and the current file count so that it can calculate and show the percentage complete.
 

MelG

New Member
Joined
Jul 28, 2011
Messages
21
I've got a new problem now. There's something not right with the code I've highlighted in blue. After "frmProgressBar.Show" the progress bar appears on screen and does nothing. If I close the progress bar it runs the rest of the code and then gets stuck in the same place again.

Option Explicit
Dim cnt As Long
Dim Filestotal As Integer
Sub ListFiles()
Dim objFSO As FileSystemObject
Dim MyPath As String
Dim MyArray() As String
Dim objFiles As Object

cnt = 0

Set objFSO = CreateObject("Scripting.FileSystemObject")

Sheets.Add

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Select a Folder"
.Show
If .SelectedItems.Count > 0 Then
MyPath = .SelectedItems(1)

Filestotal = CountFiles(objFSO, MyPath)
MsgBox Filestotal


Call ProcessFolders(objFSO, MyPath, MyArray)
Else
Exit Sub
End If
End With
Cells.Clear
If cnt > 0 Then
Range("A1:B1").Value = Array("File Path", "File Name")
Range("A2").Resize(UBound(MyArray, 2), UBound(MyArray, 1)).Value = WorksheetFunction.Transpose(MyArray)
Else
MsgBox "No files were found...", vbExclamation

End If

End Sub
Sub ProcessFolders(ByRef f, ByVal p, ByRef arr)
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Set objFolder = f.GetFolder(p)
Dim Percentage, counter As Long
For Each objFile In objFolder.Files
cnt = cnt + 1

frmProgressBar.Show
Percentage = (cnt / Filestotal) * 100
frmProgressBar.ProgressBar1.Value = Percentage
frmProgressBar.LblPercent = Str(Percentage) & "%"


ReDim Preserve arr(1 To 2, 1 To cnt)
arr(1, cnt) = objFolder.path
arr(2, cnt) = objFile.Name
Next objFile
For Each objSubFolder In objFolder.SubFolders
Call ProcessFolders(f, objSubFolder, arr)
Next objSubFolder
End Sub
Function CountFiles(fso As FileSystemObject, folderPath As String) As Long

Dim objFolder As Folder
Dim objSubFolder As Folder

Set objFolder = fso.GetFolder(folderPath)

CountFiles = CountFiles + objFolder.Files.Count

For Each objSubFolder In objFolder.SubFolders
CountFiles = CountFiles + CountFiles(fso, objSubFolder.path)
Next

End Function
 

Johnny C

Well-known Member
Joined
Nov 7, 2006
Messages
1,003
You need to refresh the form. Use either
frmProgressBar..repaint
or
DoEvents

The first only updates the form, the latter makes all calculations/file saves complete and refreshes the form. this will be a tad slower, if you can't notice a difference then go for DoEvents.
 

MelG

New Member
Joined
Jul 28, 2011
Messages
21
I've tried the repaint and doevents and still having to close the progress bar to get it to move to the next line of code.

Sub ProcessFolders(ByRef f, ByVal p, ByRef arr)
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Set objFolder = f.GetFolder(p)
Dim Percentage, counter As Long

frmProgressBar.Show
For Each objFile In objFolder.Files
cnt = cnt + 1
Percentage = (cnt / Filestotal) * 100
frmProgressBar.ProgressBar1.Value = Percentage
frmProgressBar.LblPercent = Str(Percentage) & "%"
DoEvents
ReDim Preserve arr(1 To 2, 1 To cnt)
arr(1, cnt) = objFolder.path
arr(2, cnt) = objFile.Name

Next objFile
For Each objSubFolder In objFolder.SubFolders
Call ProcessFolders(f, objSubFolder, arr)
Next objSubFolder
frmProgressBar.Hide
End Sub
 

Johnny C

Well-known Member
Joined
Nov 7, 2006
Messages
1,003
First things first: you need some type conversion functions in there. Maybe it isn't crashing but it's good practice. E.g. Percentage is a long which is a whole number but (cnt / Filestotal) * 100 will usually evaluate to a number with a decimal fraction. So try
Code:
Percentage = CLng((cnt / Filestotal) * 100)
Bizarre as it sounds that might fix it; sometimes Excel just stops if you get an error when a form is running. Have you run it without the progress bar updates (see if you get any errors flagged up)?

Also, you aren't setting the property of the label:
Code:
frmProgressBar.LblPercent = Str(Percentage) & "%"
should be
Code:
frmProgressBar.LblPercent.caption = Str(Percentage) & "%"

Try that and see what happens.

 

Johnny C

Well-known Member
Joined
Nov 7, 2006
Messages
1,003
PS I do it the same way John W's link recommends.

However if you don't want a form, there is an ActiveX progress bar object, do a search for that. Downside is you need to enable ActiveX objects each time you open the sheet; if it's just you using it you can set your Excel to automatically allow ActiveX commands.
 

Forum statistics

Threads
1,082,258
Messages
5,364,081
Members
400,778
Latest member
Canadian Sal

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top