VBA для копирования файлов PDF из одного места в другое с помощью индикатора выполнения

Question

У меня есть импортированный CSV, который всегда помещает номера деталей в столбец B, PDF чертежа детали находится в центральном месте.Я пытаюсь скопировать каждый чертеж из одной папки в другую, с этой частью я успешно справился, однако некоторые файлы могут иметь до 3000 строк, что означает, что копирование может занять некоторое время, и может показаться, что Excelне работает.

Я создал индикатор прогресса из некоторого полезного учебника, но я изо всех сил пытаюсь объединить их.Я понимаю, что индикатор выполнения должен что-то вычислить, чтобы переместить ползунок, поэтому я включил подпрограмму для подсчета количества уникальных записей в столбце B (это будет количество рисунков, которые необходимо скопировать). Затем рисунок можно использовать для созданияпроцент выполнения?

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")

Answer 1

Вот как я кодирую свой индикатор выполнения

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

И в моем сабе, который делает вещи:

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

Или

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

Answer 2

вам нужно добавить какую-то ссылку на ваш текущий номер строки в подпрограмме PDFcopy ().затем посчитайте общее количество циклов, которые необходимо выполнить.и, наконец, определите процент, который нужно передать в индикатор выполнения!

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")

Answer 3

Это в поддержку моего комментария об использовании индикатора выполнения

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