![]() |
|
#1
|
|||
|
|||
|
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 |