Microsoft Office Forums

Go Back   Microsoft Office Forums > >

 
 
Thread Tools Display Modes
Prev Previous Post   Next Post Next
  #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: 77
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
 



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 08:32 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