Question

我正在使用它来尝试复制excel列表中列表中存在的照片。它似乎检查，但没有在源文件夹中看到任何内容，并从下面的代码返回“做N”。我已启用宏，文件夹看不到锁定。任何帮助都会很有帮助

 Option Explicit

Sub CopyFiles()
    Dim iRow As Integer         ' ROW COUNTER.
    Dim sSourcePath As String
    Dim sDestinationPath As String
    Dim sFileType As String

    Dim bContinue As Boolean

    bContinue = True
    iRow = 1


    ' THE SOURCE AND DESTINATION FOLDER WITH PATH.
    sSourcePath = "C:\Users\username\Desktop\source\"
    sDestinationPath = "C:\Users\username\Desktop\TARGET\"

    sFileType = ".jpg"      ' TRY WITH OTHER FILE TYPES LIKE ".pdf".

    ' LOOP THROUGH COLUMN "A" TO PICK THE FILES.
    While bContinue

        If Len(Range("A" & CStr(iRow)).Value) = 0 Then    ' DO NOTHING IF THE COLUMN IS BLANK.
            MsgBox "Process executed" ' DONE.
            bContinue = False
        Else
            ' CHECK IF FILES EXISTS.

            If Len(Dir(sSourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then
                Range("B" & CStr(iRow)).Value = "Does N"
                Range("B" & CStr(iRow)).Font.Bold = True
            Else
                Range("B" & CStr(iRow)).Value = "On Hand"
                Range("B" & CStr(iRow)).Font.Bold = False

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

                    ' CHECK IF DESTINATION FOLDER EXISTS.
                    If objFSO.FolderExists(sDestinationPath) = False Then
                        MsgBox sDestinationPath & " Does Not Exists"
                        Exit Sub
                    End If

                    '*****
                    ' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
                    ' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
                    ' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.

                    ' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
                    objFSO.CopyFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
                        sFileType, Destination:=sDestinationPath

                    ' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
                    'objFSO.MoveFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
                        sFileType, Destination:=sDestinationPath
                    '*****
                End If
            End If
        End If

       iRow = iRow + 1      ' INCREMENT ROW COUNTER.
    Wend
End Sub

Answer 1

您不应该在每次迭代时创建新的FileSystemObject。此外，目标文件夹只能检查一次 - 无需每次都检查。

通过一些更改，请参阅下面的代码。

Option Explicit

Sub CopyFiles()
    On Error GoTo Errproc

    Const sSourcePath As String = "C:\Users\username\Desktop\source\"
    Const sDestinationPath As String = "C:\Users\username\Desktop\TARGET\"
    Const sFileType As String = ".jpg"

    'validate destination folder
    If Len(Dir(sDestinationPath)) = 0 Then
        MsgBox "Destination path does not exist..."
        Exit Sub
    End If

    Dim iRow As Integer
        iRow = Range("A" & Rows.Count).End(xlUp).Row

    Dim rr As Range, r As Range
    Set rr = Range("A1:A" & iRow)

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

    For Each r In rr
        With objFSO
            If Not .FileExists(sSourcePath & r.Value & sFileType) Then
                r.Offset(0, 1).Value = "Does N"
                r.Offset(0, 1).Font.Bold = True
            Else
                r.Offset(0, 1).Value = "On Hand"
                r.Offset(0, 1).Font.Bold = False

                objFSO.CopyFile sSourcePath & r.Value & sFileType, sDestinationPath, True 'Overwrite
                'objFSO.MoveFile Source:=sSourcePath & r.Value & sFileType , Destination:=sDestinationPath
            End If
        End With
    Next r

Leave:
    Set objFSO = Nothing
    On Error GoTo 0
    Exit Sub

Errproc:
    MsgBox Err.Description, vbCritical
    Resume Leave
End Sub

根据excel列表将文件从源文件夹复制到目标

1 个答案: