VBA to copy pdf files from one location to another with progress bar

Question

I have an imported CSV which will always put part numbers into Column B, the part drawing PDF is located in a central location. I am trying to copy each drawing from one folder location to another, this part i have been successful with, however some of the files can have up to 3000 lines which means the copy sub can take some time to complete and may seem like excel is not functioning.

I have created a progress bar from some helpful tutorial, but i am struggling to combine them. I understand the progress bar needs to calculate something in order to move the slider so i included a sub to count the number of unique entries in column B ( this would be the number of drawing which need copied ) The figure can then be used to create a percentage of completion?

Sub start()
    UserForm1.Show
End Sub


Sub code()  
    Dim i As Integer, j As Integer, pctCompl As Single
    'Sheet1.Cells.Clear

    For i = 1 To 100
        For j = 1 To 1000
            Cells(i, 1).Value = j
        Next j
        pctCompl = i
        progress pctCompl
    Next i 
End Sub


Sub progress(pctCompl As Single)    
    UserForm1.Text.Caption = pctCompl & "% Completed"
    UserForm1.Bar.Width = pctCompl * 2
    UserForm1.Caption = ListCount & "Files"

    DoEvents
End Sub


Sub CountUniqueValues()
    Dim LstRw As Long, Rng As Range, List As Object, ListCount As Long
    LstRw = Cells(Rows.Count, "B").End(xlUp).Row
    Set List = CreateObject("Scripting.Dictionary")

    For Each Rng In Range("B2:B" & LstRw)
      If Not List.Exists(Rng.Value) Then List.Add Rng.Value, Nothing
    Next

    ListCount = List.Count
End Sub

Sub PDFcopy()
    Dim R As Range
    Dim SourcePath As String, DestPath As String, FName As String

    'Setup source and dest path (Note: must have a trailing backslash!)
    SourcePath = "G:\test-copyfrom\" 'choose directory to copy from
    DestPath = "C:\test-copyto\"     'choose directory to copy to

    'Visit each used cell in column B
    For Each R In Range("B1", Range("B" & Rows.Count).End(xlUp))
        'Search the file with the file mask from the cell (Note: can contain wildcards like *.xls)
        FName = Dir(SourcePath & R.Value & ".pdf")
        'Loop while files found
        Do While FName <> ""
            'Copy the file
            FileCopy SourcePath & FName, DestPath & FName
            'Search the next file
            FName = Dir()
        Loop
    Next

    MsgBox ("files copied")

Why not just use the progress bar, set it's min and max and then increment? — Nathan_Sav, Jan 30 '19 at 15:31
I dont know how to do that, also i need to combine everything — James Hurst, Jan 30 '19 at 15:33
Note that row counting variables must be of type `Long` because Excel has more rows than `Integer` can handle: `Dim i As Long` • I recommend [always to use Long instead of Integer](https://stackoverflow.com/a/26409520/3219613) in VBA since there is no benefit in `Integer` at all. — Pᴇʜ, Jan 30 '19 at 15:33
Thats part of an example from the progress bar tutorial, ill remove it — James Hurst, Jan 30 '19 at 15:35
In `Sub CountUniqueValues` you declare `ListCount As Long` then set `ListCount = List.Count` and immediately `End Sub` so `ListCount` is never used. That doesn't make any sense. — Pᴇʜ, Jan 30 '19 at 15:39
i created the sub to see if it would count the values, i originally had a msgbox appear with the listcount value, but i wanted to utilize that figure to set the progress bar slider — James Hurst, Jan 30 '19 at 15:41

score 1 · Answer 1 · answered Jan 30 '19 at 15:40

Here's how I code my progress bar

Sub progress(percentComplete As Single)
ProgressBar.Text.Caption = percentComplete & "% Completed"
ProgressBar.Bar.Width = percentComplete * 2
DoEvents 
End Sub

And in my sub that does stuff:

'Update ProgressBar at certain points in the code
percentComplete = 11
progress percentComplete

Or

For each cell in Range("A1:A" & LRow)
'Do stuff

'Update ProgressBar in a loop
percentComplete = 11 + Int(cell.Row / LRow * 60) 'where 11 is the starting value, and 60 the percentage to be added
progress percentComplete
Next cell

score 0 · Answer 2 · answered Jan 30 '19 at 15:38

0

This is to support my comment about using the progress bar

Dim f As UserForm1

Sub SetUpAProgressBar()

Set f = New UserForm1
f.Show vbModeless

f.ProgressBar1.Min = 0
f.ProgressBar1.Max = Range("a" & Rows.Count).End(xlUp).Row
f.ProgressBar1.Value = 0

End Sub


Sub IncrementProgressBar()
    f.ProgressBar1.Value = f.ProgressBar1.Value + 1
End Sub

answered Jan 30 '19 at 15:38

Nathan_Sav

8,466
2
13
20

Right click on the tool box, and select Additional Controls and then add Progress Bar control from there. – Nathan_Sav Jan 30 '19 at 15:39

score 0 · Answer 3 · answered Jan 30 '19 at 15:48

you need to add some sort of reference to your current row number in PDFcopy() sub. then count the total amount of loops to be completed. and finally, work out the percentage to pass to the progress bar!

Sub PDFcopy()

  Dim R As Range
  Dim I as long
  Dim Total as long
  Dim SourcePath As String, DestPath As String, FName As String

  'Setup source and dest path (Note: must have a trailing backslash!)
  SourcePath = "G:\test-copyfrom\" 'choose directory to copy from
  DestPath = "C:\test-copyto\"     'choose directory to copy to

  'Visit each used cell in column B
  I = 0
  Total = Range("B" & Rows.Count).End(xlUp)
  For Each R In Range("B1", Range("B" & Rows.Count).End(xlUp))
    'Search the file with the file mask from the cell (Note: can contain wildcards like *.xls)
    FName = Dir(SourcePath & R.Value & ".pdf")
    'Loop while files found
    Do While FName <> ""
      'Copy the file
      FileCopy SourcePath & FName, DestPath & FName
      'Search the next file
      FName = Dir()
    Loop

   I = I + 1
   call progress(I/(total/100))
  Next

  MsgBox ("files copied")

Beware that `progress(I/(total/100))` will NOT return integers, which is not preferred for progress bars — Tim Stack, Jan 30 '19 at 15:50

VBA to copy pdf files from one location to another with progress bar

3 Answers3