I’ve seen some documentation on this but so far, nothing that I’ve been able to replicate for my specific project.
My code points at a directory that contains 60 or so subfolders. Within these subfolders are multiple files .PDF/.XLS etc. The following code works fine if the files are not embedded in the subfolders but what I need to do is be able to loop through the subfolders and pull the files themselves to move. Also, is there a way to eventually pull files by wildcard name? Thanks in advance for any help.
Dim FSO As Object Dim FromPath As String Dim ToPath As String Dim Fdate As Date Dim FileInFromFolder As Object FromPath = "H:\testfrom\" ToPath = "H:\testto\" Set FSO = CreateObject("scripting.filesystemobject") For Each FileInFromFolder In FSO.getfolder(FromPath).Files Fdate = Int(FileInFromFolder.DateLastModified) If Fdate >= Date - 1 Then FileInFromFolder.Copy ToPath End If Next FileInFromFolder End Sub
You can also use recursion. Your folder can have subfolders having subfolders having …
Public Sub PerformCopy() CopyFiles "H:\testfrom\", "H:\testto\" End Sub Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String) 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 FileInFromFolder 'Next loop throug folders For Each FolderInFromFolder In FSO.getfolder(strPath).SubFolders CopyFiles FolderInFromFolder.Path, strTarget Next FolderInFromFolder End Sub
I managed to get this code to work. It copies all folders / files and sub folders and their files to the new destination (strTarget).
I have not added checks and balances like 1) if the files and folders exist already. 2) if the source files are open etc. So those additions could be useful.
I got this code from Barry’s post but needed to change it to make it work for me, so thought i’d share it again anyway.
Hope this is useful though. . .
strPath is the source path and strTarget is the destination path. both paths should end in ‘\’
Note: one needs to add “Microsoft Scripting Runtime” under “Tools / References” for FSO to work.
==================== call ================================ MkDir "DestinationPath" CopyFiles "SourcePath" & "\", "DestinationPath" & "\" ==================== Copy sub =========================== Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String) Dim FSO As Object Dim FileInFromFolder As Object Dim FolderInFromFolder As Object Dim Fdate As Long Dim intSubFolderStartPos As Long Dim strFolderName As String 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 End Sub
I found the solution here:
Private Sub Command3_Click() Dim objFSO As Object 'FileSystemObject Dim objFile As Object 'File Dim objFolder As Object 'Folder Const strFolder As String = "H:\testfrom2\" Const strNewFolder As String = "H:\testto\" Set objFSO = CreateObject("Scripting.FileSystemObject") For Each objFolder In objFSO.GetFolder(strFolder & "\").SubFolders 'If Right(objFolder.Name, 2) = "tb" Then For Each objFile In objFolder.Files 'If InStr(1, objFile.Type, "Excel", vbTextCompare) Then On Error Resume Next Kill strNewFolder & "\" & objFile.Name Err.Clear: On Error GoTo 0 Name objFile.Path As strNewFolder & "\" & objFile.Name 'End If Next objFile 'End If Next objFolder End Sub