#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 |
|
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 |