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

ranjan · 08-19-2023, 09:00 AM

Hi,

I had tried the below one's not getting work...

Please check once and do the needful.

I need to copy files from sub-folder & folder to another location, i want it to "recurse" through as many levels as it finds?

Column A is file names, B is status updation if it is available update as "available" else "n/a" (A1,B1 are headings, From A2 to A100 & B2 to B100 are the range)

Files names will be excluding the extenstions in column "A". if a file name entered in A2 as 123 and update status in B2 as "available".
I want to copy all the files with the same file name with different extentions as 123.pdf, 123.rtf, 123.docx to a targeted folder, similarly File name for A3 456 ,A4 789 and copy all the formats if the file name exists in folders and sub folders....and same update the status in B2)

Code:

Sub CopyFilesBasedOnXcelValue()
    Dim srcFolder As String
    Dim destFolder As String
    Dim fileTypes As Variant
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    ' Input folder location
    srcFolder = InputBox("Enter the source folder location:")
    
    ' Destination folder location
    destFolder = InputBox("Enter the destination folder location:")
    
    ' File types to search for
    fileTypes = Array("*.pdf", "*.doc", "*.docx", "*.rtf", "*.xls", "*.xlsx")
    
    ' Set the worksheet to the active sheet
    Set ws = ActiveSheet
    
    With ws
        ' Get the last row in column A
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        ' Loop through each row in column A
        For i = 1 To lastRow
            ' Check if the file is available
            If FileExists(srcFolder & "\" & .Cells(i, "A").Value, fileTypes) Then
                ' Copy the file to the destination folder
                FileCopy srcFolder & "\" & .Cells(i, "A").Value, destFolder & "\" & .Cells(i, "A").Value
                ' Update the status in column B
                .Cells(i, "B").Value = "Available"
            Else
                ' Update the status in column B
                .Cells(i, "B").Value = "N/A"
            End If
        Next i
    End With
End Sub

Function FileExists(filePath As String, fileTypes As Variant) As Boolean
    Dim fileName As String
    Dim fileType As Variant
    Dim filesFound As Boolean
    Dim i As Long
    
    ' Check if the file exists with any of the specified file types
    For Each fileType In fileTypes
        fileName = Dir(filePath & fileType)
        If Len(fileName) > 0 Then
            filesFound = True
            Exit For
        End If
    Next fileType
    
    FileExists = filesFound
End Function