I have a folder with many sub-folders and inside of them more then 1000 Excel files.
There are two problems with the following code.
This will require me to click continue for each Excel file that needs compatibility
I need to apply that macro inside those files.
I mean that I want that macro to be available after the code runs on the files for reuse in other computer after sending those excel files to other computer
Sub ProcessFiles()
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Dim MyPath As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo EmptyEnd
MyPath = .SelectedItems(1)
End With
Application.ScreenUpdating = False
Set objFSO = CreateObject("Scripting.FileSystemObject")
Call GetAllFiles(MyPath, objFSO)
Call GetAllFolders(MyPath, objFSO)
Application.ScreenUpdating = True
MsgBox "Complete."
EmptyEnd:
End Sub
Sub GetAllFiles(ByVal strPath As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objFile As Object
Set objFolder = objFSO.GetFolder(strPath)
For Each objFile In objFolder.Files
DoWork objFile.Path
Next objFile
End Sub
Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objSubFolder As Object
Set objFolder = objFSO.GetFolder(strFolder)
For Each objSubFolder In objFolder.subfolders
Call GetAllFiles(objSubFolder.Path, objFSO)
Call GetAllFolders(objSubFolder.Path, objFSO)
Next objSubFolder
End Sub
Sub DoWork(strFile As String)
Dim wb As Workbook
If Right(strFile, 4) = "xlsx" Then
Set wb = Workbooks.Open(Filename:=strFile)
With wb
'Do your work here
......
.Close True
End With
End If
End Sub
Try the minor modifications in the code below (instead of your Sub ProcessFiles code)
Sub ProcessFiles()
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Dim MyPath As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub ' < can use Exit Sub instead of GoTo
MyPath = .SelectedItems(1)
End With
Application.DisplayAlerts = False ' <-- add this line
Application.ScreenUpdating = False
Set objFSO = CreateObject("Scripting.FileSystemObject")
Call GetAllFiles(MyPath, objFSO)
Call GetAllFolders(MyPath, objFSO)
' restore default settings
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Complete."
End Sub
Related
Trying to get clarification on an older post. Is there a way to call the choosefolder function in several different subroutines and not have the pop up window each time it is called. Basically trying to reuse the folder path selected initially to run different subroutines using that path.
Here is a sample of the code of found. I was able to get the base to work, but can't pass it into the 3 different subroutines that would call on the choose folder.
VBA - selecting a folder and referencing it as the path for a separate code
Make ChooseFolder() into a function and then reference it:
Public Function ChooseFolder()
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
ChooseFolder = sItem
Set fldr = Nothing
End Function
Private Sub btn_LeaveReport()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim sFldr As String
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
sFldr = ChooseFolder()
Set objFolder = objFSO.GetFolder(sFldr)
i = 3
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 2) = objFile.Name
'print file path
Cells(i + 1, 3) = objFile.Path
i = i + 1
Next objFile
End Sub
Like this:
Sub Main()
Dim fldr As String
fldr = ChooseFolder()
If Len(fldr) > 0 Then
PartOne fldr
PartTwo fldr
PartThree fldr
Else
MsgBox "No folder selected"
End If
End Sub
Sub PartOne(fldr as String)
'use fldr
End Sub
Sub PartTwo(fldr as String)
'use fldr
End Sub
Sub PartThree(fldr as String)
'use fldr
End Sub
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 have a VBA macro that open files in a folder, download data from an add-in, save and close.
This runs fine, but after 10 or 15 files, it gets quite slow. I think it is because Excel still keep previously opened files in the memory. I knew this because I saw the already-opened-and-closed files on the left panel as in the photo below. (the photo is to show where the panel is, I know there is only one file opened with the sheets, but you know what I mean).
My question is: is there a line of code that refresh or clear this temporary memory?
Here is my code:
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim filename As String
Dim path_to_save As String
Dim FldrPicker As FileDialog
Dim w As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Application.ScreenUpdating = False
StartTime = Timer
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Assign the folder to oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(myPath)
Set oFiles = oFolder.Files
If oFiles.Count = 0 Then GoTo ResetSettings
For Each oFile In oFolder.Files
'Set variable equal to opened workbook
myFile = oFile.Name
Set wb = Workbooks.Open(filename:=myPath & myFile)
Set cmd = Application.CommandBars("Cell").Controls("Refresh All")
cmd.Execute
DoEvents
'Ensure Workbook has opened before moving on to next line of code
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
Next 'oFile
SecondsElapsed = Timer - StartTime
MsgBox "This code ran successfully in " & SecondsElapsed
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
End Sub
What about add:
set cmd = nothing
before
wb.Close savechanges:=True
There is a known issue in Excel with closed Workbooks leaving data in Memory, which can only be cleared by closing and reopening Excel.
The below code uses a late-bound second instance of the Excel application, in an attempt to alleviate this issue; the second instance will be closed and reopened periodically (currently set to every 5 files).
Sub SomeName()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim filename As String
Dim path_to_save As String
Dim FldrPicker As FileDialog
Dim w As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
'NEW CODE
Dim appXL AS Object, counterFiles AS Long
counterFiles = 0
Application.ScreenUpdating = False
StartTime = Timer
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Assign the folder to oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(myPath)
Set oFiles = oFolder.Files
If oFiles.Count = 0 Then GoTo ResetSettings
For Each oFile In oFolder.Files
'NEW CODE
If appXL Is Nothing Then Set appNewExcel = CreateObject("Excel.Application")
DoEvents
'Set variable equal to opened workbook
myFile = oFile.Name
Set wb = appNewExcel.Workbooks.Open(filename:=myPath & myFile)
'Update / Refresh workbook
wb.RefreshAll
appNewExcel.CalculateFullRebuild
DoEvents
'Ensure Workbook has opened before moving on to next line of code
wb.Save
DoEvents
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
'NEW CODE
Set wb = Nothing
counterFiles = counterFiles+1
If counterFiles mod 5 = 0 Then
appNewExcel.Quit
Set appNewExcel = Nothing
End If
DoEvents
Next 'oFile
SecondsElapsed = Timer - StartTime
MsgBox "This code ran successfully in " & SecondsElapsed
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
End Sub
This question already has answers here:
Get list of sub-directories in VBA
(5 answers)
Closed 2 years ago.
I have a folder where I have many sub-folders and inside of them more than 1000 Excel files.
I want to run a specific macro (that changes a workbook) on all these files.
Already saw the following answer.
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\C:\...\EXCL\"
Filename = Dir(Pathname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
......
End With
End Sub
There are two problems:
1. this will be extremely slow. Is there a faster way?
2. this will only run on the files in the matching folder and not the files in all sub-folders. Is there way to do that for files in sub-folders as well?
As far as I know, VBA can't edit closet workbook. If you want to do work for every workbook in every subfolder, subfolder of subfolder etc. you can use the following code. I added condition, that it have to be .xlsx file, you can change it on .xls, .xlsb or whatever you want.
Sub ProcessFiles()
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Dim MyPath As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo EmptyEnd
MyPath = .SelectedItems(1)
End With
Application.ScreenUpdating = False
Set objFSO = CreateObject("Scripting.FileSystemObject")
Call GetAllFiles(MyPath, objFSO)
Call GetAllFolders(MyPath, objFSO)
Application.ScreenUpdating = True
MsgBox "Complete."
EmptyEnd:
End Sub
Sub GetAllFiles(ByVal strPath As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objFile As Object
Set objFolder = objFSO.GetFolder(strPath)
For Each objFile In objFolder.Files
DoWork objFile.Path
Next objFile
End Sub
Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objSubFolder As Object
Set objFolder = objFSO.GetFolder(strFolder)
For Each objSubFolder In objFolder.subfolders
Call GetAllFiles(objSubFolder.Path, objFSO)
Call GetAllFolders(objSubFolder.Path, objFSO)
Next objSubFolder
End Sub
Sub DoWork(strFile As String)
Dim wb As Workbook
If Right(strFile, 4) = "xlsx" Then
Set wb = Workbooks.Open(Filename:=strFile)
With wb
'Do your work here
......
.Close True
End With
End If
End Sub
If I get this right you need a function which collects all xl files in a directory and subdirs. This function will do that:
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
And this shows how to use it
Sub TesterFiles()
Dim colFiles As New Collection
RecursiveDir colFiles, "Your Dir goes here...", "*.XLS*", True
Dim vFile As Variant
For Each vFile In colFiles
' Do sth with the file
Debug.Print vFile
Next vFile
End Sub
Nice one Storax! I would use the script that Storax posted, and modify it just a tad.
i = 1
Dim vFile As Variant
For Each vFile In colFiles
' Do sth with the file
Range("A" & i).Value = vFile
i = i + 1
Next vFile
I think it's just easier to work with a list. Anyway, once you have the file structure, you can run through those elements in the array you just created. Use the script below to do that.
Sub LoopThroughRange()
Dim rng As Range, cell As Range
Set rng = Range("A1:A13")
For Each cell In rng
'For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(cell)
On Error GoTo 0
If Not mybook Is Nothing Then
'Change cell value(s) in one worksheet in mybook
On Error Resume Next
With mybook.Worksheets(1)
If .ProtectContents = False Then
.Range("A1").Value = "My New Header"
Else
ErrorYes = True
End If
End With
If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Close mybook without saving
mybook.Close savechanges:=False
Else
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If
'Next Fnum
Next cell
End Sub
The idea comes straight from here.
http://www.rondebruin.nl/win/s3/win010.htm
Pay attention to this part:
'Change cell value(s) in one worksheet in mybook
That's where you want to put specific your code to do exactly what you want to do.
I just modified my OP. It's a lot easier, and a little different, than I initially made it out to be. I've adjusted the script accordingly.
So my code works before I put in the end if, but once I try to implement the condition for if cancel is selected, I get a "else without if " compile error or something like that. I'm basically trying to do this:
This is the portion of my code that I'm talking about:
Public Function ChooseFolder()
'Declaring variables
Dim fldr As FileDialog
Dim sItem As String
'Folder selection
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
NextCode:
ChooseFolder = sItem
Set fldr = Nothing
Else
MsgBox ("You did not select any folders")
End If
End With
End Function
Ok so the above has been fixed thanks to your help. What error I'm getting now (although it doesn't prevent the code from working is in this segment:
Private Sub btn_LeaveReport()
'Declaring variables
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim sFldr As String
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Added this bc of stack overflow advice. Basically how to reference path via string
sFldr = ChooseFolder()
Set objFolder = objFSO.GetFolder(sFldr)
'Hardcoded version commented out since the above choose folder option is available
'Set objFolder = objFSO.GetFolder("D:\Administration\Time Sheets")
i = 3
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 2) = objFile.Name
'print file path
Cells(i + 1, 3) = objFile.Path
i = i + 1
Next objFile
End Sub
For some reason the Set objFolder is creating a runtime error regarding an invalid procedure call. However, the program still works so I'm confused what the issue is.
The problemis the line
If .Show <> -1 Then GoTo NextCode
In VBA this is already a complete IF clause, so the later ELSE and End If are missing the starting IF clause.
Is this what you are trying?
Public Function ChooseFolder()
'Declaring variables
Dim fldr As FileDialog
Dim sItem As String
'Folder selection
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show = -1 Then
sItem = .SelectedItems(1)
ChooseFolder = sItem
Else
MsgBox ("You did not select any folders")
End If
End With
Set fldr = Nothing
End Function