VBA宏可从多个子文件夹复制文件

Question

I have a VBA for copying images from one folder to another based on image names. You can check macro in work in attached. Code is:

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 = 2

    ' THE SOURCE AND DESTINATION FOLDER WITH PATH.
    sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
    sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"

    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 "Images have been moved. Thank you!" ' 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 Not Exists"
                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("B" & CStr(iRow)).Value & _
                        sFileType, Destination:=sDestinationPath
                    '*****
                End If
            End If
        End If

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

However, I need 2 more things to add to this code:

1. When I enter the name of the file to be copied, I also want to copy files that have the same name PLUS extension _01/_02/.../_07 if those exist.
2. I want macro to look not only inside specified folder but also in subfolders inside the folder and subfolders inside the subfolder etc.

Can anyone help? Thanks!

Answer 1

What you need is some Recursive Subs to find all the similar filenames based on the Range value.

Here I will approach this goal with below code with a couple of steps:

1. For each Range value (stored as a Key in Dictionary ), find all the file names (exact and similar as Item in Dictionary). Joining each finding with "|" (an illegal file name character).
2. Process the Dictionary items after all files and sub folders from Source Path
3. For each Item in the dictionary of a key, see if existing file in destination folder. Append " (i)" to destination file name if already exists.
4. Copy the destination file to destination folder.

5. While copying, it returns the

6. Stop looping when first Empty cell is encountered

NOTE: Code not been tested, only compiled fine

Option Explicit

    ' THE SOURCE AND DESTINATION FOLDER WITH PATH.
Private Const sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
Private Const sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"
Private Const sFileType = "jpg"        ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
Private Const DIV = "|" ' A character that's not legal file name

Private objFSO As Object, objDict As Object

Sub CopyFilesAlike()
    Dim lRow As Long, sName As String
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(sSourcePath) Then
        MsgBox "Source folder not found!" & vbCrLf & sSourcePath, vbCritical + vbOKOnly
        GoTo I_AM_DONE
    End If
    If Not objFSO.FolderExists(sDestinationPath) Then
        MsgBox "Destination folder not found!" & vbCrLf & sDestinationPath, vbCritical + vbOKOnly
        GoTo I_AM_DONE
    End If
    ' Proceed when both Source and Destination folders found
    Set objDict = CreateObject("Scripting.Dictionary")
    lRow = 2
    Do Until IsEmpty(Cells(lRow, "A")) ' Stop on first empty cell in Column A from lRow
        ' Get Main file name to look up
        sName = Cells(lRow, "A").Value
        ' Look for files (exact and alikes from sub folders) to add to dictionary
        LookForFilesAlike sName, objFSO.GetFolder(sSourcePath)
        ' Copy files
        If objDict.Count = 0 Then
            Cells(lRow, "B").Value = "No files found."
        Else
            Cells(lRow, "B").Value = objDict.Count & " filenames(s) found." & vbLf & CopyFiles
        End If
        ' Clear the Dictionary for next Name
        objDict.RemoveAll
        ' Increment row counter
        lRow = lRow + 1
    Loop
    Set objDict = Nothing

I_AM_DONE:
    Set objFSO = Nothing
End Sub

Private Sub LookForFilesAlike(ByVal sName As String, ByVal objFDR As Object)
    Dim oFile As Object, oFDR As Object
    ' Add files of current folder to dictionary if name matches
    For Each oFile In objFDR.Files
        If InStr(1, oFile.Name, sName, vbTextCompare) = 1 Then ' Names beginning with sName
            ' Check the extension to match
            If LCase(objFSO.GetExtensionName(oFile)) = LCase(sFileType) Then
                If objDict.Exists(oFile.Name) Then
                    ' Append Path to existing entry
                    objDict.Item(oFile.Name) = objDict.Item(oFile.Name) & DIV & oFile.Path
                Else
                    ' Add Key and current path
                    objDict.Add oFile.Name, oFile.Path
                End If
            End If
        End If
    Next
    ' Recurse into each sub folder
    For Each oFDR In objFDR.SubFolders
        LookForFilesAlike sName, oFDR
    Next
End Sub

Private Function CopyFiles() As String
    Dim i As Long, oKeys As Variant, oItem As Variant, iRepeat As Integer, sName As String, sOut As String
    sOut = ""
    ' Process the items for each key in Dictionary
    Set oKeys = objDict.Keys ' <- Add "Set " before oKeys
    For i = 0 To objDict.Count
        For Each oItem In Split(objDict.Item(oKeys(i)), DIV)
            ' Determine the filename in destination path
            If objFSO.FileExists(sDestinationPath & objFSO.GetFileName(oItem)) Then
                ' Same file name alreay found, try append " (i)"
                iRepeat = 0
                Do
                    iRepeat = iRepeat + 1
                    sName = objFSO.GetBaseName(oItem) & " (" & iRepeat & ")" & objFSO.GetExtensionName(oItem)
                Loop While objFSO.FileExists(sDestinationPath & sName)
                sName = sDestinationPath & sName
            Else
                ' First file to be copied to destination folder
                sName = sDestinationPath
            End If
            ' Copy the source file to destination file
            If Len(sOut) = 0 Then
                sOut = oItem & DIV & sName
            Else
                sOut = sOut & vbLf & oItem & DIV & sName
            End If
            objFSO.CopyFile oItem, sName
        Next
    Next
    CopyFiles = sOut
End Function