I need to copy files from folders and subfolders, but the below code search for only subfolders inside the main folder. But there are also some subfolders inside the subfolders
Eg : C:\abc\bca - for this abc is main folder and bca is subfolder, the code is working for this.
For c:\abc\bca\cab or c:\abc\zxc\cvg it is not working in folders in subfolders,
Please assist me.
Thanks in Advance
Sub copy_files_from_subfolders()
Dim fso As Object
Dim fld As Object
Dim fsofile As Object
Dim fsofol As Object
Dim filename As String
Dim snumber As Double
snumber = InputBox("Enter the Number", "Message from D")
filename = "_PTA.pdf"
sourcepath = "\\chec.local\"
destinationpath = "R:\Desa"
If Right(sourcepath, 1) <> "\" Then
sourcepath = sourcepath & "\"
End If
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.GetFolder(sourcepath)
If fso.FolderExists(fld) Then
For Each fsofol In fso.GetFolder(sourcepath).SubFolders
For Each fsofile In fsofol.Files
If InStr(1, fsofile.Name, snumber) = 1 Then
MsgBox "Documents Copied"
fsofile.Copy destinationpath
End If
Next
Next
End If
End Sub
Related
The following code works for specified folder.
How to get it to work for all subfolders of X:\DataArchive\CMM\reports\?
Sub Copying()
Dim FSO As Object
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
Dim fileExtn As String
fileExtn = ".PDF" ''File extension
sSFolder = "X:\DataArchive\CMM\reports\2019_01\" ''Source folder
sDFolder = "C:\Users\sc00709\Desktop\501 28\" ''Destination folder
Dim i As Integer
i = 2
Do While i < 74
With ThisWorkbook
''Filename
sFile = Dir(sSFolder & "364_040_501_0_D_OP270_INSP_" & _
Worksheets("50128").Cells(i, 2) & "*" & fileExtn)
''Create Object for File System
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FileExists(sSFolder & sFile) Then
ElseIf Not FSO.FileExists(sDFolder & sFile) Then
''Copying
FSO.CopyFile (sSFolder & sFile), sDFolder, TRUE
Else
End If
End With
i = i + 1
Loop
MsgBox "You did it!", vbInformation, "Done!"
End Sub
Here is code to loop through all the folders in a folder
Sub Main()
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
ExecuteOnAllSubFolders FileSystem.GetFolder("X:\DataArchive\CMM\reports\")
End Sub
Sub ExecuteOnAllSubFolders(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
ExecuteOnAllSubFolders SubFolder
'Perform your operations here
Next
'Perform your operations and here
End Sub
Search for a file in folders and sub folders using file name if found copy to another folder in vba macros
The code shows no error but the file is not copying from the folder, i need to loop through sub folders and find a file.
Sub copy_files_from_subfolders()
Dim fso As Object
Dim fld As Object
Dim fsofile As Object
Dim fsofol As Object
sourcepath = "FINAL CUT\"
destinationpath = "Desa\MECA\"
If Right(sourcepath, 1) <> "\" Then
sourcepath = sourcepath & "\"
End If
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.GetFolder(sourcepath)
If fso.FolderExists(fld) Then
For Each fsofol In fso.GetFolder(sourcepath).SubFolders
For Each fsofile In fsofol.Files
If Right(fsofile, 6) = 566978 Then
fsofile.Copy destinationpath
End If
Next
Next
End If
End Sub
You're searching for the number using the Right-function, but this fails to take into account the file-extension that follows it. You could try something like (assuming the extension is the same):
Right(fsofile, 10) = "566978.txt" ''change extension to whatever
If the file-extensions aren't of the same length, you could determine the position of the dot in the name and use the Mid-function.
Alternatively, you could just check if the numbers you're looking for occur within the filename using, instead of the Right-function:
If InStr(1, fsofile, "566978") <> 0 then
This should only cause issues if there are files with longer strings of numbers, because for example you could have a file named "123556978123.pdf", which would be a false positive.
Here is the answer i found
Sub copy_files_from_subfolders()
Dim fso As Object
Dim fld As Object
Dim fsofile As Object
Dim fsofol As Object
sourcepath = "FINAL CUT\"
destinationpath = "Desa\MECA\"
If Right(sourcepath, 1) <> "\" Then
sourcepath = sourcepath & "\"
End If
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.GetFolder(sourcepath)
If fso.FolderExists(fld) Then
For Each fsofol In fso.GetFolder(sourcepath).SubFolders
For Each fsofile In fsofol.Files
If InStr(1, fsofile.Name, 566978 & "_PTA") = 1 Then
fsofile.Copy destinationpath
End If
Next
Next
End If
End Sub
actually I am searching for code to move excel files from one folder to another if there is any way to do so Please someone help me. I am very sorry but I dont know how to do coding as I have never used VBA in fact I see it for the first time.
I will be grateful to you
Sub MoveFiles()
Dim FSO As Object
Dim SourceFileName As String, DestinFileName As String
Set FSO = CreateObject("Scripting.Filesystemobject")
SourceFileName = "C:\Users\Jun.xlsx"
DestinFileName = "C:\Users\Desktop\Jun.xlsx"
FSO.MoveFile Source:=SourceFileName, Destination:=DestinFileName
MsgBox (SourceFileName + " Moved to " + DestinFileName)
End Sub
Try with the below code
Sub test()
Set fso = CreateObject("scripting.filesystemobject")
fso.MoveFile Source:="C:\work\test1.xlsx", Destination:="c:\work\movecheck\" ' replace with source and destination as required.
End Sub
Below is code which moves only Excel (xlsx) files from source folder into destination folder. Other types files will be left in the destination folder.
Sub MoveFiles()
Dim sourceFolderPath As String, destinationFolderPath As String
Dim FSO As Object, sourceFolder As Object, file As Object
Dim fileName As String, sourceFilePath As String, destinationFilePath As String
Application.ScreenUpdating = False
sourceFolderPath = "D:\SourceFolder"
destinationFolderPath = "D:\DestinationFolder"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set sourceFolder = FSO.Getfolder(sourceFolderPath)
For Each file In sourceFolder.Files
fileName = file.Name
If InStr(fileName, ".xlsx") Then ' Only xlsx files will be moved
sourceFilePath = file.Path
destinationFilePath = destinationFolderPath & "\" & fileName
FSO.MoveFile Source:=sourceFilePath, Destination:=destinationFilePath
End If ' If InStr(sourceFileName, ".xlsx") Then' Only xlsx files will be moved
Next
'Don't need set file to nothing because it is initialized in for each loop
'and after this loop is automatically set to Nothing
Set sourceFolder = Nothing
Set FSO = Nothing
End Sub
If you need move only one file the best solution is:
Name sourceFolderPath & fileName As destinationFilePath
You can use the Filesystemobject:
Dim FSO as Object
Set FSO = CreateObject("Scripting.Filesystemobject")
FSO.MoveFile("SourceFileName", "TargetFileName")
Feel free to comment, if you need further instructions.
Sub move_data()
'Move test data to folder
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim Fdate As Date
Dim FileInFromFolder As Object
MkDir "D:\TEST\" 'Create new folder name TEST in D:
FromPath = "E:\test\" 'Source files
ToPath = "D:\TEST\" 'Target destination
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
For Each FileInFromFolder In FSO.getfolder(FromPath).Files
FileInFromFolder.move ToPath
Next FileInFromFolder
End Sub
try :
Sub movefile()
Dim fso As New FileSystemObject
Dim fil As file
Dim SourcePath, BackUpPath As String
SourcePath = "C:\mydata\"
BackUpPath = "G:\Backup\"
For Each fil In fso.GetFolder(SourcePath).Files
fName = fso.GetFileName(fil)
Name fil As BackUpPath & fName
Next fil
End Sub
I have a ton of files that have a common string in the name "mch". Within one folder there are hundreds of subfolders named with this common string, then within those there are 5 pictures named similar; example picfront1234mch. I need to get rid of the mch at the end of all the names of picture files and the folders they are in. I was attempting a couple different examples from the web but non to work. I wrote this code to find the file names in the subfolders and to delete the last 3 characters of the name but its deleting the extensions instead. I have used the move/copy/ rename method in the past but I lost some of my old code and can’t figure out how use it again. Any suggestions on how to do this better?
Code ive been trying
Option Explicit
Sub ListFiles()
'Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String
'Assign the top folder to a variable
strTopFolderName = "C:\Users\aholiday\Desktop\Test"
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)
'Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True)
End Sub
Sub RecursiveFolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean)
'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim str As String
Debug.Print Now
Application.SendKeys "^g ^a {DEL}"
Application.ScreenUpdating = False
'Loop through each folder in the Topfolder
For Each objFile In objFolder.Files
str = objFile.Name
Debug.Print str
'delete last 3 chara of string
str = Left(str, Len(str) - 3)
Debug.Print str
Next objFile
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If
Application.ScreenUpdating = True
End Sub
Usage:
RemoveTextFromFileName "mch", "I:\stackoverflow\temp"
Sub RemoveTextFromFileName(txt As String, FolderName As String)
Dim file
If Not Right(FolderName, 1) = "\" Then FolderName = FolderName & "\"
file = Dir(FolderName)
While (file "")
If InStr(file, txt) > 0 Then
FileCopy FolderName & file, FolderName & Replace(file, txt, "")
Kill FolderName & file
End If
file = Dir
Wend
End Sub
Update: Remove string from folder, sub folders, and file names.
These functions will recursively search the root folder and all it's subfolders to rename files and folders.
Usage:
Public Sub ProcessFoldersAndFiles()
ReplaceStringFileNames "C:\Data Files\mch files\", "mch"
ReplaceStringDirectories"C:\Data Files\mch files\", "mch"
End Sub
Here are the functions:
Sub ReplaceStringDirectories(FolderPath As String, SearchString As String, Optional ReplacementString As String = "", Optional fso As Object)
Dim fld, thisFolder
Dim NewName As String, PathOnly As String
If fso Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
End If
Set thisFolder = fso.getFolder(FolderPath)
For Each fld In thisFolder.Subfolders
ReplaceStringDirectories fld.Path, SearchString, ReplacementString
Next
If InStr(thisFolder.Name, SearchString) Then
NewName = Replace(thisFolder.Name, SearchString, ReplacementString, , , vbTextCompare)
PathOnly = Left(thisFolder.Path, InStrRev(thisFolder.Path, "\"))
Do Until Not fso.FolderExists(PathOnly & NewName)
NewName = "_" & NewName
Loop
thisFolder.Name = NewName
End If
End Sub
Sub ReplaceStringFileNames(FolderPath As String, SearchString As String, Optional ReplacementString As String = "", Optional fso As Object)
Dim f, fld, thisFolder
Dim NewName As String, PathOnly As String
If fso Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
End If
Set thisFolder = fso.getFolder(FolderPath)
For Each fld In thisFolder.Subfolders
ReplaceStringFileNames fld.Path, SearchString, ReplacementString
Next
For Each f In thisFolder.Files
If InStr(f.Name, SearchString) Then
NewName = Replace(f.Name, SearchString, ReplacementString, , , vbTextCompare)
PathOnly = Left(f.Path, InStrRev(thisFolder.Path, "\"))
Do Until Not fso.FolderExists(PathOnly & NewName)
NewName = "_" & NewName
Loop
f.Name = NewName
End If
Next
End Sub
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