#1
|
|||
|
|||
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 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 |
#2
|
||||
|
||||
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.
|
#3
|
|||
|
|||
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 |
#4
|
|||
|
|||
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 |
#5
|
||||
|
||||
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?) |
|
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 |
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 multiple files as text without extensions | Metamag | Office | 3 | 05-09-2011 06:25 PM |