I use the following code to loop through the files in the folders, open the file and then wait for data to load and save and stop. however, it keeps repeating the loop. That is, after the last file, it starts again with the first file and keeps looping. What is wrong?
Sub morningstar_open_and_save_only_VBA()
'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
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
Application.ScreenUpdating = False
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 = "*.xlsx*"
'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)
Set cmd = Application.CommandBars("Cell").Controls("Refresh All")
cmd.Execute
'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
'Get next file name
myFile = Dir
Loop
SecondsElapsed = Round(Timer - StartTime, 2)
'Message Box when tasks are completed
MsgBox "Task Complete! in " & SecondsElapsed & " seconds"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Just made some research , I guess you can adpat the code from another post (see link : Get list of Excel files in a folder using VBA)
You can adapt the loop to your need and it's more elegant !
For Each oFile In oFiles
Next
I hope it help ! Take care !
Related
I am using the below code to loop through all workbooks in a chosen folder and change some content in Sheet1 of each workbook. But when the code is finished, the content is successfully changed but all sheets are hidden. Not sure why and how to fix it?
Sub LoopChangeCoreName()
Dim wb, newwb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim i, m As Integer
Dim LR As Long
Dim r As Integer
Dim rng As Range
Dim AuthorName As String
Dim CoreName As String
'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 <> ""
Application.ScreenUpdating = False
'Set variable equal to opened workbook
Set wb = GetObject(myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
If InStr(myFile, "_") > 0 Then AuthorName = Split(myFile, "_")(0)
For m = 2 To wb.Sheets(1).UsedRange.Rows.Count
CoreName = AuthorName & "_" & wb.Sheets(1).Range("A" & m).Value
wb.Sheets(1).Range("A" & m) = CoreName
Next m
DoEvents
'Save and Close Workbook
wb.Sheets(1).Visible = True
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
(repeat only to pass the post check) I am using the below code to loop through all workbooks in a chosen folder and change some content in Sheet1 of each workbook. But when the code is finished, the content is successfully changed but all sheets are hidden. Not sure why and how to fix it? Thank you so much.
Good afternoon,
I would like to check all files in my directory.
For this purpose, I decided to loop through all of them.
The good code I found here:
https://www.thespreadsheetguru.com/the-code-vault/2014/4/23/loop-through-all-excel-files-in-a-given-folder
and changed it consequently for my personal purpose.
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
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 = "*.xlsm*"
'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
'Change First Worksheet's Background Fill Blue
wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
'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
but it looks like the code works for the first file only.
I am not only one with this problem, because I found the similar problems here:
VBA Loop through excel workbooks in folder and copy data - Not looping through all files
Excel-VBA Loop not looping through all files in folder
Is there a way to make this code working for all files instead of one?
or should I use better For Each instead of Do While ?
My problem is very similar to this issue:
Code Stopping While Looping through files on workbook.close
the new file is not prompted at all. In my VBA console is "no project selected"
I have seemingly the same code and it works fine.
When i pickup some code somewhere i tend to make small changes step by step and make sure its still working every change i make.
Sub LoopThroughFilesvieux()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xWB As Workbook
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
On Error Resume Next
Do While xFileName <> ""
Set xWB = Workbooks.Open(xFdItem & xFileName)
With xWB
'yourcode
End With
xWB.Close
xFileName = Dir
Loop
End If
End Sub
You can probably start again from my structure or the original structure you took that from and add your code lines little by little, also, try to run it step by step to see where it exits.
I am writing a function that iterates through files in a folder. In each file, iterate through the sheets and save them as CSV files. I tested them without going through the sheets and it works fine. However, when I loop through the sheets, it keeps looping through the files. I ran the debug and found that when it is at the end of the last file, it goes back to the first file. I cannot find what was wrong. Here is my code:
Sub morningstar_VBA()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
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
'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 = "*.xlsx*"
'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
For w = 1 To Worksheets.Count
With Worksheets(w).Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
filename = .Worksheets(1).Name
path_to_save = "E:\Morningstar_download\test\" & filename
.SaveAs filename:=path_to_save, FileFormat:=xlCSV
DoEvents
.Close savechanges:=False
End With
End With
Next w
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
Maybe try this out :
Sub morningstar_VBA()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
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
'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 = "*.xlsx*"
'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)
Windows(wb.Name).Visible = False
'Ensure Workbook has opened before moving on to next line of code
For w = 1 To wb.Worksheets.Count
With wb.Worksheets(w).Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
filename = ActiveWorkbook.Worksheets(1).Name
path_to_save = "E:\Morningstar_download\test\" & filename
wb.SaveAs Filename:="E:\Morningstar_download\test\" & filename & ".csv", FileFormat:=xlCSVWindows
Workbooks( Worksheets(w).Name & ".XLS").Close
End With
Next w
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
i would split this into two parts; mainly because it is easier to handle the code, but also in case you need parts of the code in other circumstances. The sub "Dateien_auswaehlen" can be used to do anything with the choosen files, just by choosing some other routine then morningstar:
Sub Dateien_auswaehlen()
Dim FldrPicker As FileDialog
Dim fso As Object
Dim objFld As Object
Dim objFiles As Object
Dim file
Dim myPath As String
'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 = "*.xlsx*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFld = fso.GetFolder(myPath)
Set objFiles = objFld.Files
For Each file In objFiles
'here any sub can be called for working with the files found:
If LCase(file.Name) Like myExtension Then Call morningstar_VBA(myPath, file.Name)
Next
'Message Box when tasks are completed
MsgBox "Task Complete!"
Set fso = Nothing
Set objFld = Nothing
Set objFiles = Nothing
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub morningstar_VBA(path As String, filename As String)
Dim wb As Workbook
Dim myFile As String
Dim myExtension As String
Dim path_to_save As String
Dim w As Long
Set wb = Workbooks.Open(path & filename)
'Ensure Workbook has opened before moving on to next line of code
For w = 1 To Worksheets.Count
With Worksheets(w).Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
filename = .Worksheets(1).Name
path_to_save = "E:\Morningstar_download\test\" & filename
.SaveAs filename:=path_to_save, FileFormat:=xlCSV
DoEvents
.Close savechanges:=False
End With
End With
Next w
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
End Sub
I have hundreds of excel files that need to be uploaded, but are currently in file type .xlsb
I need them to be file type .xlsx
Don't really know much about excel macros so I am looking for help.
Tried using some code I found online that uses VBA through excel's macro dev function (Sorry for poor wording, I'm an excel novice).
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim fpath As String
Dim wname As String
'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)
wname = Left(wb.Name, InStr(wb.Name, ".") - 1)
fpath = wb.Path & "\" & wname
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Save and Close Workbook
wb.SaveAs Filename:=fpath & ".xlsx", FileFormat:= _
xlExcel12, CreateBackup:=False
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
I get a
runtime error "1004":
This extension cannot be used with this file type.
You must open each workbook and save it as XLSX; you can't simple change the extension from XLSB to XLSX. The code below will do what you want.
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 = "*.xlsb"
'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
'Save and Close Workbook
wb.SaveAs FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'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: After user3561813 the suggestion of adding "/", it now read the first file. I have an out of range error message "9". It does read the first file correctly. Ultimately I am trying to open each file, and read the name and age (this is a testing not the real production form). And retrieve the values back to my main worksheet.
Original question
I am trying to read hundred of excel forms in a folder, read a particular cell position, and record them into my testing worksheet. I googled this tutorial and tried to write my code. But when I execute the Getting Folder function, selected a folder path, it does not loop the excel files I have. (or record their names)
'Source: https://www.youtube.com/watch?v=7x1T4s8DVc0
Sub GettingFolder()
Dim SelectedFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select folder"
.ButtonName = "Confirm"
.InitialFileName = "U:\"
If .Show = -1 Then
'ok clicked
SelectedFolder = .SelectedItems(1)
MsgBox SelectedFolder
' This is where I want to call my function
LoopFiles (SelectedFolder)
Else
'cancel clicked
End If
End With
End Sub
' Source: http://www.excel-easy.com/vba/examples/files-in-a-directory.html
Sub LoopFiles(path As String)
Dim directory As String, fileName As String, sheet As Worksheet
Dim i As Integer, j As Integer
' Avoid Screen flicker and improve performance
Application.ScreenUpdating = False
' Fixed per suggestion below..
directory = path & "\"
fileName = Dir(directory & "*.xl??")
Do While fileName <> ""
i = i + 1
j = 2
Cells(i, 1) = fileName
Workbooks.Open (directory & fileName)
For Each sheet In Workbooks(fileName).Worksheets
Workbooks("Testing.xlsm").Worksheets(1).Cells(i, j).Value = sheet.Name
j = j + 1
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
' Reset the screen update setting
Application.ScreenUpdating = True
End Sub
Interesting question! This should do it for you. Modify as needed.
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
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 = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Row = 1
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Change First Worksheet's Background Fill Blue
ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value = Worksheets(1).Range("A1").Value
Row = Row + 1
'Save and Close Workbook
wb.Close SaveChanges:=True
'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
In your code, the path variable may not contain a trailing backslash. This causes the following code in your LoopFiles(<>) SubRoutine to be inaccurate:
directory = path
fileName = Dir(directory & "*.xl??")
Filename would look something like: c:\users\name\documentshello.xlsx
Try changing the above code to:
directory = path & "\"
fileName = Dir(directory & "*.xl??")
Does that fix the problem?