I have the following code that will open/save/close any/all workbooks in a folder. It works great, however, I also need it to include sub folders. The code needs to work without restrictions on the number of folders, sub folders and files, if possible.
I'm working with Excel 2010 and I'm new to VBA - would really appreciate any help!
Sub File_Loop_Example()
'Excel VBA code to loop through files in a folder with Excel VBA
Dim MyFolder As String, MyFile As String
'Opens a file dialog box for user to select a folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
'stops screen updating, calculations, events, and statsu bar updates to help code run faster
'you'll be opening and closing many files so this will prevent your screen from displaying that
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'This section will loop through and open each file in the folder you selected
'and then close that file before opening the next file
MyFile = Dir(MyFolder & "\", vbReadOnly)
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
ActiveWorkbook.Save
Workbooks(MyFile).Close SaveChanges:=True
MyFile = Dir
Loop
'turns settings back on that you turned off before looping folders
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
MsgBox "Done!"
End Sub
For anyone interested, I found an alternative which I managed to adapt and does exactly what I want:
Sub Loop_Example()
Dim MyFolder As String
Dim file As Variant, wb As Excel.Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
Application.ScreenUpdating = False
For Each file In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & startFolder & "*.xl*"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
Set wb = Workbooks.Open(file)
ActiveWorkbook.Save
wb.Close SaveChanges:=True
Set wb = Nothing
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Related
I have a VBA script below that loops through files in a folder. I would like to find and replce any "$" with "" (nothing) in columns I and J.
When I run this script it appears to run, but there are no changes within the files. Not too sure where the issue is. Any help would be appreciated.
Thanks!
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'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
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Find and replace col I and J
wb.Worksheets(1).Range("I:J").Replace What:="$", Replacement:=""
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
*Edit - I have found it will work with .xlsx files, but not with .csv. I would need it to work with csv, so any suggestions would be great.
Try something like this:
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String, ext
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show = -1 Then myPath = .SelectedItems(1)
End With
If myPath <> "" Then
myPath = myPath & "\"
For Each ext In Array("*.xls*", "*.csv") 'loop different extension patterns
myFile = Dir(myPath & ext)
Do While myFile <> ""
'Debug.Print myFile
Set wb = Workbooks.Open(Filename:=myPath & myFile)
wb.Worksheets(1).Range("I:J").Replace _
What:="$", Replacement:="", LookAt:=xlPart
wb.Close SaveChanges:=True
myFile = Dir()
Loop
Next ext
End If
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Note - where possible you should avoid use of Goto for flow control. You only really need Goto for handling runtime errors (or maybe for breaking out of nested loops).
Option Explicit
Sub AllWorkbooks()
Dim MyFolder As String
Dim MyFile As String
Dim wbk As Workbook
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
MyFile = Dir(MyFolder)
Do While MyFile <> ""
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
Sheets(2).Range("A1").Value = "hi!"
wbk.Close savechanges:=True
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
I copy the code from this video https://www.youtube.com/watch?v=J0PeXcAVaUM&t=169s.
When I tried to run this code, it shows "run-time error 52: Bad file name or number"
It seems that "MyFile = Dir(MyFolder)" has a problem.
How can I solve this? Thank you so much!
I have a folder with more than 300+ excel files and what I want to open each of the excel files inside the folder and run specific macro that's already stored in each of the excel files, save it, close it and move to the next file.
The macro which is stored in each excel file is connected to other macros inside the workbook, you could call it like a Main macro, so for example If I just tried to run the Main macro, without the macros it's connected, to all the files at the same time, it just wouldn't work, because it is connected to other macros. The code below is what I've done so far, but it doesn't work as intended
Sub run_mYearChange
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim wb As Workbook, ws As Worksheet
Dim wPath As String, wQuan As Long, n As Long
Dim fso As Object, folder As Object, subfolder As Object, wFile As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
wPath = .SelectedItems(1)
End With
Set fso = CreateObject("scripting.filesystemobject")
Set folder = fso.getfolder(wPath)
wQuan = folder.Files.Count
n = 1
For Each wFile In folder.Files
Application.StatusBar = "Processing folder : " & folder & ". File : " & n & " of : " & wQuan
If Right(wFile, 4) Like "*xlsm*" Then
Set wb = Workbooks.Open(wFile)
Application.Run "'C:\test2\*.xlsm*'!mYearChange.YearChangeFunction"
wb.Save True
wb.Close True
End If
n = n + 1
Next
Set fso = Nothing: Set folder = Nothing: Set wb = Nothing
MsgBox "End"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
I'm trying to find a solution everywhere and without luck. In this website there also hasn't been anything similar to what I'm asking. I would love all the help I could get, I'm kind of desperate, because nothing works.
Thank you for your help in advance.
You need to adjust the file name for each file opened.
Untested:
Sub run_mYearChange
'snipped....
Dim wPath As String, n As Long, f
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
wPath = .SelectedItems(1)
End With
if right(wPath, 1) <> "\" then wPath = wPath & "\"
f = Dir(wPath & "*.xlsm")
Do While Len(f) > 0
With Workbooks.Open(wPath & f)
Application.Run "'" & .Name & "'!mYearChange.YearChangeFunction"
.Close True 'save
End With
n = n + 1
f = Dir()
Loop
MsgBox "End"
'snipped...
End Sub
This script should go into a folder full of excel files, rename the files by the author name & a count, and save them to a new folder.
However, this now saves the file not as an excel document, but the filetype is also the name of the author and the count.
I have edited the code from the suggested comments but now I receive this error:
Runtime Error
Did I edit the code wrong?
Sub RenameExcelFilesbyAuthor()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Counter As Integer
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.CalculateBeforeSave = False
Application.AskToUpdateLinks = False
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "C:\Users\Name\Documents\Excel 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
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Counter = 1
'Loop through each Excel file in folder
Do While myFile <> ""
'ReadOnly = False
Set wb = Nothing
On Error Resume Next
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
On Error GoTo 0
If wb Is Nothing Then
On Error Resume Next
wb.Close
Else
Counter = Counter + 1
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
ThisWorkbook.BuiltinDocumentProperties("Author") = Author
wb.SaveAs Filename:="C:\Users\max\Documents\New folder\" & wb.BuiltinDocumentProperties("Author") & Counter & myExtension, FileFormat:=xlWorkbookDefault
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
End If
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
[1]: https://i.stack.imgur.com/XVPT1.png
I'm trying to open set of files from a specific folder. But while trying to open one of the files i get the attached Sign In pop-up.
email signin
I don't know how to get rid of this because we don't want someone to manually undo this, also, i'm cancelling the pop-up I get below pop-up
I just click No/Yes i get a Run time error.
But the designated file is open (Daily Testing Inventory file).
Here's my macro that I achieved so far:
Dim MyFolder As String
Dim MyFile As String
Application.ScreenUpdating = False
Application.EnableEvents = False
MyFolder = "C:\"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
DoEvents
Loop
I'm a newbie as far as Excel VBA is concerned. (Since I don't have enough reputation can't post all the images)
You are not reading the next file name. hence the loop is infinite.
Please add the following line above "DoEvents":
MyFile = Dir()
Turn off Alerts as well
better synatx as well
use a Workbook object to hold the opened workbooks
do your code
close each Workbook (the code below does so without saving)
then trigger your next loop
code
Sub recut()
Dim MyFolder As String
Dim MyFile As String
Dim Wb As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
MyFolder = "C:\"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Set Wb = Workbooks.Open(MyFolder & "\" & MyFile)
'do code
Wb.Close False
MyFile = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub