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
Related
I am no expert when it comes to using VBA. However, I have a task to convert thousnds of files located in folders and sub folders. I have found online the below code and my question is: can the code be modified in a way that it can delete the old .xls files after conversion?
Public Sub test()
RenameFilesInFolders "M:\test\", True
MsgBox "Finished"
End Sub
Public Sub RenameFilesInFolders(path As String, Optional recurse As Boolean)
Dim fso As Object, fldr As Object
If Right(path, 1) <> "\" Then
path = path & "\"
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder(path)
renameFiles fldr, recurse
End Sub
Private Sub renameFiles(fldr As Object, recurse As Boolean)
Dim file As Object, subFldr As Object
For Each file In fldr.Files
changeFileExtension file
Next
If recurse And fldr.SubFolders.Count > 0 Then
For Each subFldr In fldr.SubFolders
renameFiles subFldr, recurse
Next
End If
End Sub
Private Sub changeFileExtension(file As Object)
Dim xlFile As Workbook
Dim strCurrentFileExt As String
Dim strNewFileExt As String
Dim strNewName As String
strCurrentFileExt = ".xls"
strNewFileExt = ".xlsx"
strNewName = file.Name
If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then
Set xlFile = Workbooks.Open(file.path, , True)
strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt)
Application.DisplayAlerts = False
Select Case strNewFileExt
Case ".xlsx"
xlFile.SaveAs file.ParentFolder & "\" & strNewName, XlFileFormat.xlOpenXMLWorkbook
Case ".xlsm"
xlFile.SaveAs file.ParentFolder & "\" & strNewName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled
End Select
xlFile.Close
Application.DisplayAlerts = True
End If
End Sub
Store path (called in your RenameFilesInFolders Sub) in a variable (for example PathToFile) and use this command : Kill PathToFile.
Afterwards you can even check if the file is deleted with this (if you enabled Microsoft Scripting Runtime) :
Dim FSO As FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim PathToFile As String
If (FSO.FileExists(PathToFile) Then 'If the file still exists
'Your code
End If
Set FSO = Nothing
I am trying to Loop through all files and sub folders but my code is just works for single folder.
I want to apply this code on all Folders and subfolder which have workbooks.
Any help will be appreciated.
Sub KeepColor()
Dim strFolder As String
Dim strFile As String
Dim wbk As Workbook
Dim wsh As Worksheet
Dim I As Long
Dim xRg As Range
With Application.FileDialog(4)
If .Show Then
strFolder = .SelectedItems(1)
Else
MsgBox "You 't selected a folder!", vbExclamation
Exit Sub
End If
End With
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
Application.ScreenUpdating = FALSE
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open(strFolder & strFile)
For Each wsh In wbk.Worksheets
For Each xRg In wsh.UsedRange
If xRg.DisplayFormat.Interior.ColorIndex = xlColorIndexNone Then
xRg.Interior.ColorIndex = xlColorIndexNone
Else
xRg.Interior.Color = xRg.DisplayFormat.Interior.Color
End If
Next xRg
wsh.UsedRange.FormatConditions.Delete
Next wsh
wbk.Close SaveChanges:=True
strFile = Dir
Loop
Application.ScreenUpdating = TRUE
End Sub
Dir is much faster than FileSystemObject if you have a filename pattern, so here's a function which mixes both:
Sub Tester()
Dim col As Collection, t
t = Timer
Set col = GetMatches("C:\Tester", "*.xls*")
Debug.Print Timer - t, col.Count
End Sub
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fpath
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
'this is faster...
fpath = fldr.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
f = Dir(fpath & filePattern)
Do While Len(f) > 0
colFiles.Add fso.getfile(fpath & f)
f = Dir()
Loop
'this is slower...
'For Each f In fldr.Files
' If UCase(f.Name) Like filePattern Then colFiles.Add f
'Next f
Loop
Set GetMatches = colFiles
End Function
Please, try the next code:
Sub KeepColor()
Dim strFolder As String, fso As Object, parentFolder As Object, folder As Object
With Application.FileDialog(4)
If .Show Then
strFolder = .SelectedItems(1)
Else
MsgBox "You didn't select a folder!", vbExclamation
Exit Sub
End If
End With
Set fso = CreateObject("scripting.filesystemobject")
Set parentFolder = fso.GetFolder(strFolder)
Application.ScreenUpdating = False
ProcessAllFiles parentFolder, "xls*"
For Each folder In parentFolder.SubFolders
ProcessAllFiles folder, "xls*"
Next
Application.ScreenUpdating = True
End Sub
Sub ProcessAllFiles(strFold As Object, fileExt As String)
Dim fso As Object, objFile As Object, xRg As Range, wbk As Workbook, wsh As Worksheet
Set fso = CreateObject("scripting.filesystemobject")
For Each objFile In strFold.files
If fso.GetExtensionName(objFile.Name) Like fileExt Then
Set wbk = Workbooks.Open(objFile.path)
For Each wsh In wbk.Worksheets
For Each xRg In wsh.UsedRange
If xRg.DisplayFormat.Interior.ColorIndex = xlColorIndexNone Then
xRg.Interior.ColorIndex = xlColorIndexNone
Else
xRg.Interior.color = xRg.DisplayFormat.Interior.color
End If
Next xRg
wsh.UsedRange.FormatConditions.Delete
Next wsh
wbk.Close SaveChanges:=True
End If
Next
End Sub
This is a recursion job.
I am using a generic function, that returns a collection of all files (could be changed to array as well) - either for the folder or for all subfolders.
You need to add a reference to "Microsoft Scripting runtime"
Option Explicit
Sub testFindAllFiles()
Dim strFolder As String: strFolder = "XXXX" 'adjust to your needs
Dim colFiles As Collection
Set colFiles = findAllFilesByExtension(strFolder, "xls*", True)
Dim strFile As Variant
For Each strFile In colFiles
Debug.Print strFile
'do what you need with the file
Next
End Sub
Public Function findAllFilesByExtension(ByVal targetFolder As String, ByVal extension As String, _
Optional fWithSubfolders As Boolean = True) As Collection
Dim fso As FileSystemObject: Set fso = New FileSystemObject
Dim colFiles As Collection: Set colFiles = New Collection
findFilesByExtension targetFolder, colFiles, extension, fso, fWithSubfolders
Set findAllFilesByExtension = colFiles
End Function
Private Sub findFilesByExtension(ByVal targetFolder As String, ByRef colFiles As Collection, _
extension As String, fso As FileSystemObject, fWithSubfolders As Boolean)
Dim objFolder As Folder, objFile As File
Dim subFolders As Folders
Set objFolder = fso.GetFolder(targetFolder)
For Each objFile In objFolder.Files
If Not objFile.Name Like "~*" Then
If objFile.Name Like "*." & extension Then
colFiles.Add objFile.Path
End If
End If
Next
If fWithSubfolders = True Then
Set subFolders = objFolder.subFolders
For Each objFolder In subFolders
findFilesByExtension objFolder.Path, colFiles, extension, fso, fWithSubfolders
Next
End If
End Sub
I need to open a specified workbook using a text box entry and using a list command to open it.
I used a cell value before and it worked but I would like to use a textbox value to make it easier for the operator.
So when I click on the listbox value it takes the textbox value then finds the workbook and opens it
I`ve also asked Mr. Excel see below
https://www.mrexcel.com/board/threads/opening-workbook-from-user-form.1161913/
Private Sub Worksheet_Change(ByVal Target As Object)
If Target.Me.Jobcard_Demands = ("Open Old JobCard") Then
Me.Old_JobCard_No.Value
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Object)
Dim PID As Double
Dim strRootPath As String
Dim objFile As Scripting.File
Dim wb As Workbook
Dim myfilename As String
Dim Test As String
Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
If Target.Me.Jobcard_Demands = ("Open Old JobCard") Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("\\TGS-SRV01\Share\ShopFloor\PRODUCTION\JOB CARDS\1 - ARCHIVED JOB CARDS\" & Int((ActiveSheet.Range("C1") - 1) / 50) * 50 + 1 & "-" & Int((ActiveSheet.Range("C1") - 1) / 50 + 1) * 50 & "\" & ActiveSheet.Range("C1"))
For Each objFile In objFolder.Files
If Left(objFile.Name, 5) = CStr(ActiveSheet.Range("C1")) And Right(objFile.Name, 4) = "xlsm" Then
myfilename = objFile.Path
End If
Next objFile
Set wb = Workbooks.Open(myfilename)
End If
End Sub
Private Sub JobCardOpen(ByVal Target As Object)
Dim objFile As Scripting.File
Dim wb As Workbook
Dim myfilename As String
Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
If Target.Me.Jobcard_Demands = ("Open Old JobCard") Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("\\TGS-SRV01\Share\ShopFloor\PRODUCTION\JOB CARDS\1 - ARCHIVED JOB CARDS\" & Int((ActiveSheet.Range("C1") - 1) / 50) * 50 + 1 & "-" & Int((ActiveSheet.Range("C1") - 1) / 50 + 1) * 50 & "\" & ActiveSheet.Range("C1"))
For Each objFile In objFolder.Files
If Left(objFile.Name, 5) = ActiveSheet.Range("C1") Then
myfilename = objFile.Path & objFile.Name
End If
Next objFile
Set wb = Workbooks.Open(myfilename)
End Sub
I don't understand what you are using the Worksheet_Change and Worksheet_SelectionChange events for, I would suggest using a button to trigger the event and an InputBox for the user to enter the number.
Option Explicit
Sub JobCardOpen() ' assign to button
Dim wb As Workbook, jobno As Long
jobno = InputBox("Enter Job No")
Set wb = OpenJobCard(jobno)
' process wb
If wb Is Nothing Then
Else
MsgBox wb.Name & " workbook is open", vbInformation
wb.Close
End If
End Sub
Function OpenJobCard(jobno As Long) As Workbook
Const ROOT = "\\TGS-SRV01\Share\ShopFloor\PRODUCTION\JOB CARDS\1 - ARCHIVED JOB CARDS\"
Dim objFSO, objFolder, objFile
Dim n As Long, sFolderName As String, bFound As Boolean
n = 50 * Int((jobno - 1) / 50)
sFolderName = ROOT & CStr(n + 1) & "-" & CStr(n + 50) & "\" & CStr(jobno)
Set objFSO = CreateObject("Scripting.FileSystemObject")
' check folder exists
If objFSO.FolderExists(sFolderName) Then
Set objFolder = objFSO.GetFolder(sFolderName)
Else
MsgBox sFolderName & "\ not found", vbCritical, "Folder not found"
Exit Function
End If
bFound = False
For Each objFile In objFolder.Files
If objFile.Name Like CStr(jobno) & "*.xlsm" Then
Set OpenJobCard = Workbooks.Open(objFile.Path)
bFound = True
End If
Next objFile
If bFound = False Then
MsgBox "No File found in " & sFolderName, vbCritical, "File not found"
Exit Function
End If
End Function
I am looking for a way to select multiple .jpg file in a folder and copy it to another folder. This is the code I am working with, but it doesn't seem to be able to move it to the destination file.
I'm also using an excel worksheet where I paste those filenames which I want to copy in Row A.
Sub CopyFiles()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
FromPath = "Directory" 'Folder From
ToPath = "Directory" 'Folder To
Worksheets("Files to Copy").Activate
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
ToPath & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
Maybe something like this...copy or Move one file
For one file you can use the VBA Name and FileCopy function and for entire folders or a lot of files use the other macro example's on this page.
Copy or Move one file
For one file you can use the VBA Name and FileCopy function and for entire folders or a lot of files use the other macro example's on this page.
Sub Copy_One_File()
FileCopy "C:\Users\Ron\SourceFolder\Test.xls", "C:\Users\Ron\DestFolder\Test.xls"
End Sub
OR
Sub Move_Rename_One_File()
'You can change the path and file name
Name "C:\Users\Ron\SourceFolder\Test.xls" As "C:\Users\Ron\DestFolder\TestNew.xls"
End Sub
Sub CopyFiles()
'// Tools -> References -> Microsoft Scripting Runtime
Dim xRow As Long
Dim FSO As FileSystemObject
Dim FromPath$, ToPath$
Dim xFile As File
Dim xFolder As Folder
FromPath = "Directory" 'Folder From
ToPath = "Directory" 'Folder To
Worksheets("Files to Copy").Activate
Set fso = New FileSystemObject
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If Not .Show Then Exit Sub
Set xFolder = FSO.GetFolder(.SelectedItems(1))
For Each xFile In xFolder.Files
On Error Resume Next
xRow = Application.Match(xFile.Name, Range("A:A"), 0)
If Err = 0 Then
xFile.Copy ToPath & Cells(xRow, "B").Value
End If
On Error GoTo 0
Next
End With
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