Question

我已经尝试了解循环和我的工作表的逻辑。我试图根据excel文件中的条件或列H = YES将.pdf文件从文件夹传输到另一个文件夹。我在代码底部得到语法错误

**objFSO.CopyFile Source:=OldPath & Range("H"&CStr(iRow)).Value & sFileType,
 Destination:=NewPath**


Sub Rectangle1_Click()
Dim iRow As Integer
Dim OldPath As String
Dim NewPath As String
Dim sFileType As String

Dim bContinue As Boolean

bContinue = True
iRow = 2

' The Source And Destination Folder With Path

OldPath = "C:\Users\bucklej\Desktop\Spec\"
NewPath = "C:\Users\bucklej\Desktop\Dest\"

sFileType = ".pdf"

'Loop Through Column "H" To Pick The Files
While bContinue

If Len(Range("H" & CStr(iRow)).Value) = Yes Then
MsgBox "Files Copied"
bContinue = False

Else

Range("H" & CStr(iRow)).Value = "No"
Range("H" & CStr(iRow)).Font.Bold = False

If Trim(NewPath) <> "" Then
Set objFSO = CreateObject("scripting.filesystemobject")

'Check if destination folder exsists

If objFSO.FolderExists(NewPath) = False Then
MsgBox NewPath & "Does Not Exist"
Exit Sub
 End If

 'Using CopyFile Method to copy the files
 Set objFSO = CreateObject("scripting.filesystemobject")
 objFSO.CopyFile Source:=OldPath & Range("H"&CStr(iRow)).Value & sFileType,
 Destination:=NewPath

    End If
   End If
  End If

  iRow = iRow + 1

  Wend
 End Sub

下面列出的正确代码：

 Sub Rectangle1_Click()

Dim OldPath As String, NewPath As String

Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

'~~> File location bucklej
OldPath = "C:\Users\bucklej\Desktop\Specs\"
NewPath = "C:\Users\bucklej\Desktop\Dest\"

Set ws = ThisWorkbook.Sheets("Specification Listing")
Range("A2").Activate  '<--- to make sure we're starting at the right spot

For i = 2 To 1000
    If Cells(i, 8).Value = "YES" Then  '<--- correct, 8th column over
    On Error GoTo ErrHandle
        fso.CopyFile OldPath & Cells(i, 1).Value & ".pdf", NewPath
    End If
Next i

ErrHandle:
ws.Cells(i, 11).Value = "File Not Found"
Resume Next



End Sub

Answer 1

回头看第二个重复的问题和作为答案提供的代码片段我看到你说你收到错误信息并且对话已经死了。扩展到该答案后，我能够使用test.txt获得以下工作。你应该能够根据自己的需要调整它。

Sub Rectangle1_Click()


Dim OldPath As String, NewPath As String

Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

'~~> File location
OldPath = "C:\Users\me\Desktop\"
NewPath = "C:\Users\me\Desktop\Test\"

For i = 1 To 1000
    If Cells(i, 2).Value = "yes" Then
        fso.copyfile OldPath & Cells(i, 3).Value & ".txt", NewPath
    End If
Next i


End Sub

更新：我认为（也许）问题是因为它没有做任何事情，正确的表格没有被引用。将此更新的代码粘贴到“此工作簿”中。并在代码中重命名工作表名称。

Sub Rectangle1_Click()

Dim OldPath As String, NewPath As String
Dim ws As Worksheet
Dim wb As Workbook
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Test") <--rename to the sheet that has the parts numbers

'~~> File location
OldPath = "C:\Users\bucklej\Desktop\Spec\"
NewPath = "C:\Users\bucklej\Desktop\Dest\"

For i = 1 To 1000
    If ws.Cells(i, 2).Value = "YES" Then
         fso.CopyFile OldPath & Cells(i, 3).Value & ".pdf", NewPath
    End If
Next i


End Sub

再次，随时给我发电子邮件。

更新：在

中抛出错误处理的最终版本

Sub Rectangle1_Click()

Dim OldPath As String, NewPath As String

Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

'~~> File location bucklej
OldPath = "C:\Users\me\Desktop\Specs\"
NewPath = "C:\Users\me\Desktop\Dest\"

Set ws = ThisWorkbook.Sheets("Specification Listing")
Range("A2").Activate

For i = 2 To 1000
    If Cells(i, 8).Value = "YES" Then
    On Error GoTo ErrHandle
        fso.CopyFile OldPath & Cells(i, 1).Value & ".pdf", NewPath
    End If
Next i

ErrHandle:
ws.Cells(i, 11).Value = "File Not Found"

Resume Next

End Sub

如何修复编译错误/语法错误？

1 个答案: