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

Question

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

我正在研究的解决方案是使用用户窗体选择“ copyfrom”位置和“ copyto”位置，在“运行”命令按钮上，一个子项应在整个文件之间进行复制。

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

我认为可能是文本框值未记录？

另一方面，一旦例程完成，我还想在消息框中返回已移动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文件将从第一个文件夹位置复制到第二个文件夹位置。

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

一旦移动了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")

祝你好运