将 PDF 从源文件夹复制到目标文件夹

Question

我想从源文件夹中复制 pdf 并且必须根据 Excel 粘贴到目标路径中，请帮助我哪里出错了

Sub CheckandSend()   
    Dim irow As Integer   
    Dim DestPath As String   
    Dim SourcePath As String   
    Dim pfile As String  

    Dim FSO As Object   
    Dim Fldr As Object, f As Object   

    SourcePath = "I:\Mechanical\ExternalProjects\Cummins Emission Systems101124 PT Cup Test Rig PDF to Vendor" 
  
    Set FSO = CreateObject("Scripting.FileSystemObject")     
    Set Fldr = FSO.GetFolder(SourcePath).Files 

    DestPath = "P:\CENTRAL PLANNING\PROJECTS 2020-2021\VAM-TARSON\Newfolder1"    

    irow = 7    
    Do While Cells(irow, 2) <> Empty    
        pfile = Dir(SourcePath & "\*" & Cells(irow, 2) & "*")        
        If pfile <> "" And Right(pfile, 3) = "PDF" Then       
            FileCopy SourcePath, DestPath           
            irow = irow + 1           
        End If         
    Loop      
end sub

Answer 1

下面的代码有效。

Sub CheckandSend()
    ' 191

    Const Ext           As String = ".pdf"
    Dim SourcePath      As String
    Dim DestPath        As String
    Dim FSO             As Object
    Dim Fldr            As Object
    Dim pFile As String
    Dim f As Object
    Dim iRow            As Long             ' row numbers should be declared as Long
    
    ' both paths must end on backslash ("\")
    SourcePath = "I:\Mechanical\ExternalProjects\Cummins Emission Systems101124 PT Cup Test Rig PDF to Vendor\"
    DestPath = "P:\CENTRAL PLANNING\PROJECTS 2020-2021\VAM-TARSON\Newfolder1\"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Fldr = FSO.GetFolder(SourcePath).Files
    
    ' loop until last used cell in column B
    For iRow = 7 To Cells(Rows.Count, 2).End(xlUp).Row
        pFile = Trim(Cells(iRow, 2).Value)
        If Len(pFile) = 0 Then Exit For     ' exit at first blank row
        
        If LCase(Right(pFile, 4)) <> Ext Then pFile = pFile & Ext
        If Len(Dir(SourcePath & pFile)) Then
            FileCopy SourcePath & pFile, DestPath & pFile
        End If
    Next iRow
End Sub

我已经消除了您的程序中的一些不一致之处。例如，您的代码不清楚工作表中的文件名是否具有 pdf 扩展名，然后查找具有该名称的任何文件但拒绝所有不是“pdf”的文件”。上面的代码对此进行了改写，表示您想要工作表中名称的 PDF 文件以及任何名称相同但另一个扩展名的文件将被忽略。我认为它是一样的，但如果将搜索限制为 PDF 会更有效率。

另一件事是循环结束。是在没有更多文件名时还是在单元格为空时？上面的代码在任何一种情况下都结束了。我认为这没问题，因为您的文件列表中没有空白。但是，如果是这样，最好跳过任何意外的空白并继续直到处理完最后一行。如果您同意，请删除 Exit For 并在适当的位置（在 Next iRow 之前）设置一个 End If 并缩进中间的所有行。

Answer 2

您正在混合使用 2 种不同的方法：FileSystemObject 和 Dir()。只使用其中之一。
FileCopy SourcePath, DestPath只复制路径没有文件名
直接在您的 Dir() 中包含文件扩展名，因此您无需检查 pdf 文件：
```
FileName = Dir(SourcePath & "*" & ws.Cells(iRow, 2) & "*.pdf")
```

可能存在多个包含您手机中关键字的文件。您的代码随机复制其中一个。确保循环以便获得所有这些

Do While FileName <> vbNullString 'if more files with the key word from ws.Cells(iRow, 2) exist copy all of them
    VBA.FileCopy SourcePath & pfile, DestPath 'copy needs to be path AND filename
    FileName = Dir()
Loop

它可能看起来像这样：

Option Explicit

Public Sub CheckandSend()
    Dim ws As Worksheet 'make sure to define a sheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim SourcePath As String
    SourcePath = "C:\Temp\" 'make sure paths end with \

    Dim DestPath As String
    DestPath = "P:\CENTRAL PLANNING\PROJECTS 2020-2021\VAM-TARSON\Newfolder1\" 'make sure paths end with \
    
    Dim iRow As Long
    iRow = 7
    
    Do While ws.Cells(iRow, 2) <> vbNullString
        Dim FileName As String
        FileName = Dir(SourcePath & "*" & ws.Cells(iRow, 2) & "*.pdf") 'this will only go through pdf files
        
        Do While FileName <> vbNullString 'if more files with the key word from ws.Cells(iRow, 2) exist copy all of them
            VBA.FileCopy SourcePath & pfile, DestPath 'copy needs to be path AND filename
            FileName = Dir()
        Loop
        
        iRow = iRow + 1
    Loop
End Sub

将 PDF 从源文件夹复制到目标文件夹

Copy PDF from source folder to destination folder

pdf

directory

excel

vba