VBA 用于从选定文件夹位置复制 pdf 的用户表单

Question

我们从 Creo 将 CSV 文件导入 excel，这是我们的材料清单，我们创建绘图 PDF 和 DXF，并将它们保存在两个 'MASTER' 文件夹中。将图纸发给制造商时，我们必须在发送之前将每张图纸复制到单独的文件夹中。

我正在研究的解决方案是使用用户表单 select 'copyfrom' 位置和 'copyto' 位置，在 'run' 命令按钮上，子应该复制文件。

我已经通过在 Sub 例程中输入文件夹位置使用了复制代码，但我需要允许其他用户选择其他文件。用户窗体正在将文件夹位置添加到特定的文本框，但复制 pdf 的下一个子例程将不起作用。

我想可能是没有记录文本框的值？

另一方面，我还想 return 移动 PDF 的数量作为例程完成后消息框中消息的一部分。这可能与 B 列中使用的单元格数不同

图纸的零件号将始终在 B 列中

我还没有创建 DXF 选项，但如果我可以使用它，它将与 PDF 非常相似

非常感谢任何帮助。

Private Sub cmdclose_Click()
Unload Me
End Sub

Private Sub copyfromcmd_Click()

Dim fldr As FileDialog
Dim sItem As String

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    '.InitialFileName = Application.GetSaveAsFilename()
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
    End With
    NextCode:
    GetFolder = sItem
    copyfromtb.Value = sItem

Set fldr = Nothing


End Sub

Private Sub copytocmd_Click()

Dim fldr As FileDialog
Dim sItem2 As String

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    '.InitialFileName = Application.GetSaveAsFilename()
    If .Show <> -1 Then GoTo NextCode
    sItem2 = .SelectedItems(1)

End With
NextCode:
GetFolder = sItem2
copytotb.Value = sItem2

Set fldr = Nothing

End Sub

Private Sub runcmd_Click()
  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 = Me.copyfromtb.Value
  DestPath = Me.copytotb.Value

  '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 ("PDF's Copied")
End Sub

预期结果：

单击“复制文件”命令按钮时，B 列中所列部件号的 pdf 文件将从第一个文件夹位置复制到第二个文件夹位置。

如果条目为空，则会出现一条消息，要求文件夹位置 selected

移动 PDF 后，应该会出现一条消息，告诉用户已复制的文件数。

实际结果：

正在将文件夹位置输入到所需的文本框中，但未复制 PDF

Answer 1

我刚刚意识到我的错误

我需要添加结尾的反斜杠！

  SourcePath = Me.copyfromtb.Value
  DestPath = Me.copytotb.Value

改为

  SourcePath = copyfromtb.Value & "\"
  DestPath = copytotb.Value & "\"

在计算已移动文件的数量并将该值添加到最后的消息框中时仍然存在问题

Answer 2

试试这个

  dim counter as integer
  counter = 0

  '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 <> ""
      counter = counter + 1
      'Copy the file
      FileCopy SourcePath & FName, DestPath & FName
      'Search the next file
      FName = Dir()
    Loop
  Next

  MsgBox (counter & " PDF's Copied")

祝你好运

VBA 用于从选定文件夹位置复制 pdf 的用户表单

VBA userform to copy pdfs from selected folder locations

excel

vba

userform