Microsoft Office Forums - View Single Post - Copying files from multiple subfolders using vba

ranjan · 06-13-2022, 11:42 AM

Hi,

Currently am using the below macro to copy files from one path to another path based on a excel value.
Column A File Name & Column B Status (If a file is available in source path then msg as copied else doesnt exists)
File type : (".rtf", ".docx", ".pdf")

Its working only in one folder directory & not locating sub directories, can anyone help to modify the below code as copying a files from sub folders to target path.

Code:

Option Explicit

Sub CopyFiles1()                                  ''Code

    Dim iRow   As Integer                         ' ROW COUNTER.
    Dim SourcePath As String
    Dim DestinationPath As String
    Dim sFileType   As Variant                    '<- changed
    Dim bContinue As Boolean
    Dim x      As Long                            '<- added

    bContinue = True
    iRow = 2
    ' THE SOURCE AND DESTINATION FOLDER WITH PATH.
    SourcePath = InputBox("PLEASE ENTER PATH", "SOURCE PATH") & "\"
    DestinationPath = InputBox("PLEASE ENTER PATH", "DESTINATION PATH") & "\"
    sFileType = Array(".rtf", ".docx", ".pdf")    '<- changed
    'sFileType = ".docx"
    'sFileType = ".rtf"
    ' 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.
            For x = LBound(sFileType) To UBound(sFileType) '<- added
                If Len(Dir(SourcePath & Range("A" & CStr(iRow)).Value & sFileType(x))) = 0 Then
                    Range("B" & CStr(iRow)).Value = "Does Not Exists"
                    Range("B" & CStr(iRow)).Font.Bold = True
                Else
                    Range("B" & CStr(iRow)).Value = "Copied"
                    Range("B" & CStr(iRow)).Font.Bold = False
                    If Trim(DestinationPath) <> "" Then
                        Dim objFSO
                        Set objFSO = CreateObject("scripting.filesystemobject")
                        ' CHECK IF DESTINATION FOLDER EXISTS.
                        If objFSO.FolderExists(DestinationPath) = False Then
                            MsgBox DestinationPath & " 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:=SourcePath & Range("A" & CStr(iRow)).Value & sFileType(x), Destination:=DestinationPath '<- changed
                        ' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
                        'objFSO.MoveFile Source:=sSourcePath & Range("B" & CStr(iRow)).Value & sFileType(x) , Destination:=sDestinationPath
                        '*****
                    End If
                End If
            Next x                                '<- added
        End If
        iRow = iRow + 1                           ' INCREMENT ROW COUNTER.
    Wend
    Set objFSO = Nothing
    
End Sub

Now i want to add subfolders to the above code.

Your help is highly appreciated, i tried the below one but unable to frame the code.

Copying a files from sub folder's to target path based on a excel value.

Please embeded the below code to the above source code.

Code:

Set FSO = CreateObject("scripting.filesystemobject")
'First loop through files
    For Each FileInFromFolder In FSO.GetFolder(strPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'If Fdate >= Date - 1 Then
            FileInFromFolder.Copy strTarget
        'end if
    Next

    'Next loop throug folders
    For Each FolderInFromFolder In FSO.GetFolder(strPath).SubFolders
        'intSubFolderStartPos = InStr(1, FolderInFromFolder.Path, strPath)
        'If intSubFolderStartPos = 1 Then

        strFolderName = Right(FolderInFromFolder.Path, Len(FolderInFromFolder.Path) - Len(strPath))
        MkDir strTarget & "\" & strFolderName

        CopyFiles FolderInFromFolder.Path & "\", strTarget & "\" & strFolderName & "\"

    Next 'Folder