Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 06-13-2022, 11:42 AM
ranjan ranjan is offline Copying files from multiple subfolders using vba Windows 10 Copying files from multiple subfolders using vba Office 2019
Advanced Beginner
Copying files from multiple subfolders using vba
 
Join Date: May 2021
Posts: 76
ranjan is on a distinguished road
Default Copying files from multiple subfolders using vba

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
Reply With Quote
  #2  
Old 07-20-2022, 06:27 AM
BobBridges's Avatar
BobBridges BobBridges is offline Copying files from multiple subfolders using vba Windows 7 64bit Copying files from multiple subfolders using vba Office 2010 32bit
Expert
 
Join Date: May 2013
Location: USA
Posts: 700
BobBridges has a spectacular aura aboutBobBridges has a spectacular aura about
Default

Ranjan, do you want to do it for just one level of subfolder, or do you want it to "recurse" through as many levels as it finds? For the latter you want to write a "recursive" routine; the usual way to accomplish it is to write a subroutine that calls itself. Some of us here can teach you how, if you want to make the effort. I can myself.
Reply With Quote
  #3  
Old 08-19-2023, 09:00 AM
ranjan ranjan is offline Copying files from multiple subfolders using vba Windows 10 Copying files from multiple subfolders using vba Office 2019
Advanced Beginner
Copying files from multiple subfolders using vba
 
Join Date: May 2021
Posts: 76
ranjan is on a distinguished road
Default

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

Last edited by ranjan; 08-19-2023 at 12:53 PM. Reason: Adding Info
Reply With Quote
  #4  
Old 02-13-2024, 01:05 PM
ranjan ranjan is offline Copying files from multiple subfolders using vba Windows 10 Copying files from multiple subfolders using vba Office 2019
Advanced Beginner
Copying files from multiple subfolders using vba
 
Join Date: May 2021
Posts: 76
ranjan is on a distinguished road
Default

Hi,

I tried the below code but getting some error.

i want it to "recurse" through as many levels as it finds, can anyone please review the code.

Your help is highly appreciated...



Code:
Option Explicit

Sub RecursiveFileSearch()
    Dim sourceFolder As String
    Dim destFolder As String
    Dim ws As Worksheet
    Dim nextRow As Long
    Dim fileName As String
    
    ' Set the source folder path
    sourceFolder = InputBox("Enter the source folder path:")
    
    ' Set the destination folder path
    destFolder = BrowseForFolder("Select the destination folder:")
    
    ' Check if the source folder path is provided
    If sourceFolder = "" Then Exit Sub
    
    ' Check if the destination folder path is provided
    If destFolder = "" Then Exit Sub
    
    ' Set the worksheet object
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Replace "Sheet1" with your actual sheet name
    
    ' Find the next available row in the worksheet
    nextRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    
    ' Call the recursive search function
    RecursiveSearch sourceFolder, ws, nextRow, destFolder
    
    MsgBox "File search complete!", vbInformation
End Sub

Sub RecursiveSearch(ByVal folder As String, ByVal ws As Worksheet, ByRef nextRow As Long, ByVal destFolder As String)
    Dim fileSystem As Object
    Dim file As Object
    Dim subFolder As Object
    Dim fileName As String
    Dim filePath As String
    Dim fileExtension As String
    Dim found As Boolean
    
    ' Create the file system object
    Set fileSystem = CreateObject("Scripting.FileSystemObject")
    
    ' Loop through each file in the folder
    For Each file In fileSystem.GetFolder(folder).Files
        ' Get the file name and extension
        fileName = fileSystem.GetBaseName(file.Name)
        fileExtension = LCase(fileSystem.GetExtensionName(file.Path))
        
        ' Search for file name in column A and update status in column B
        found = False
        With ws.Range("A:A")
            Set file = .Find(fileName, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
            If Not file Is Nothing Then
                found = True
                
                ' Update status as available
                ws.Cells(file.Row, 2).value = "Available"
                
                ' Copy the file to destination folder if it matches the allowed file types
                If fileExtension = "docx" Or fileExtension = "rtf" Or fileExtension = "pdf" Or fileExtension = "xlsx" Then
                    file.Copy destFolder & "\" & fileName & "." & fileExtension
                End If
            End If
        End With
        
        ' If file name not found, update status as not available
        If Not found Then
            nextRow = nextRow + 1
            ws.Cells(nextRow, 1).value = fileName
            ws.Cells(nextRow, 2).value = "Not Available"
        End If
    Next file
    
    ' Recursively search sub-folders
    For Each subFolder In fileSystem.GetFolder(folder).SubFolders
        RecursiveSearch subFolder.Path, ws, nextRow, destFolder
    Next subFolder
End Sub


Function BrowseForFolder(ByVal prompt As String) As String
    Dim objShell As Object, objFolder As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, prompt, 0)
    
    If Not objFolder Is Nothing Then
        BrowseForFolder = objFolder.self.Path & "\"
    Else
        BrowseForFolder = ""
    End If
    
    Set objFolder = Nothing
    Set objShell = Nothing
End Function
Reply With Quote
  #5  
Old 02-13-2024, 02:23 PM
BobBridges's Avatar
BobBridges BobBridges is offline Copying files from multiple subfolders using vba Windows 7 64bit Copying files from multiple subfolders using vba Office 2010 32bit
Expert
 
Join Date: May 2013
Location: USA
Posts: 700
BobBridges has a spectacular aura aboutBobBridges has a spectacular aura about
Default

Wait, "some error"? Ranjan, tell us what error; quote it exactly. And if (as I assume) it's an execution error, it'll point to some place in the program; where does it point? What statement caused the problem?



(Why make us guess when you have that information right in front of you?)
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Batch change the font style in multiple word files inside folder and subfolders kalagas Word VBA 11 10-05-2023 05:13 AM
Pls help - copying data from multiple word files handclips Word VBA 3 01-24-2021 01:57 PM
Copying files from multiple subfolders using vba List all word files in folder and subfolders eduzs Word VBA 5 06-09-2019 06:20 AM
Searching through folders/ subfolders and rename files if certain condition is met mihnea96 Excel 1 05-15-2017 07:09 AM
Copying files from multiple subfolders using vba Copying multiple files as text without extensions Metamag Office 3 05-09-2011 06:25 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 01:49 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft