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

这是为了支持我对使用进度条的评论

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

Answer 3

您需要在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")

VBA使用进度条将pdf文件从一个位置复制到另一位置

3 个答案: