I have a function that prompts the user to select a folder and a subroutine that will consolidate the files in the folder to a single document, but I cannot get the two to work together.
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub ConslidateWorkbooksPrompt()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = GetFolder()
Filename = Dir(FolderPath & "*.csv")
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
When I save the subroutine separately and run it where FolderPath = "C:\docs\SampleFolder\" then it runs fine. Instead of having to manually change the folder path, I'd like the user to be able to select their own, but I imagine I am somehow calling the function wrong.
Related
I want to prompt the user to select the folder path with FileDialog and integrate it with a routine which imports the desired files to the open workbook.
Below is my code but rather than pre-determining the folderpath I need to prompt the user:
Sub MergeCsvFilesToWb()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim fldr As FileDialog
Application.ScreenUpdating = False
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the Folder where the '.csv' files are located."
.AllowMultiSelect = False
.Show
End With
FolderPath = fldr.SelectedItems(1)
Filename = Dir(FolderPath & "*.csv*")
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
The File/Folder selected in FileDialog can be found in the SelectedItems property (Documentation)
So to assign the variable FolderPath to the selected folder:
Dim fldr As FileDialog
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the Folder where the '.csv' files are located."
.Show
Dim FolderPath As String
FolderPath = .SelectedItems(1)
End With
Note that you should handle the event that the user does not select any folder (click Cancel) in the dialog so a better version would be:
Dim fldr As FileDialog
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the Folder where the '.csv' files are located."
.Show
Dim FolderPath As String
If .SelectedItems.Count <> 0 Then
FolderPath = .SelectedItems(1)
Else
'Code to handle event that nothing is selected
'e.g.
'Exit Sub
End If
End With
Lastly, the folder path returned does not have a slash at the end so you will need to either:
Modify Filename = Dir(FolderPath & "*.csv*") to Filename = Dir(FolderPath & "\*.csv*")
Modify FolderPath = .SelectedItems(1) to FolderPath = .SelectedItems(1) & "\"
My Aim:
This procedure is meant to loop through excel files in a specified folder and preform a sub (cleanDataAndTransfer), which is meant to clean the data in the files being looped through and then paste it in to a new sheet in the master file.
My problem:
Im getting the Run-time error '91': Object variable or With block variable not set on the .Title = "Select A Target Folder" line.
I've tried different solutions to rectify the issue but nothing has yet worked.
My code:
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
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
myExtension = "*.xls*"
myFile = Dir(myPath & myExtension)
Do While myFile <> ""
Set wb = Workbooks.Open(FileName:=myPath & myFile)
DoEvents
Call cleanDataAndTransfer
wb.Close SaveChanges:=True
DoEvents
myFile = Dir
Loop
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I would really appreciate any suggestions on how to solve this bug and any other improvements! Thanks in advance :)
I don't have a Mac to test this but you could try an InputBox.
update - no filter on Dir
Sub loopAllExcelFilesInFolder()
Sub loopAllExcelFilesInFolder2()
Const EXT = "csv"
Dim wb As Workbook, myPath As String, myFile As String
Dim count As Integer, isWindows As Boolean
myPath = ThisWorkbook.Path & Application.PathSeparator
myPath = VBA.InputBox("Enter folder", "Folder", myPath)
If myPath = "" Then Exit Sub
If Right(myPath, 1) <> Application.PathSeparator Then
myPath = myPath & Application.PathSeparator
End If
myFile = Dir(myPath)
Do While myFile <> ""
If Right(myFile, Len(EXT)) = EXT Then
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Call cleanDataAndTransfer
wb.Close SaveChanges:=True
count = count + 1
End If
myFile = Dir
Loop
MsgBox count & " files cleaned", vbInformation
End Sub
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 a bit of code to pick out all xlsx files in a folder and place them into one workbook. I was wondering if I could get the vba to find the folder the master work book is saved in or if the vba could ask which folder I want to select.
Sub GetSheets()
Path = "S:\xxxxx\"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Path = ThisWorkbook.Path
should do the trick.
You can refer This:
Sub openfldr()
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Sub
I have under mentioned code for merging excel files into one workbook with multiple sheets. It works perfectly. I want some help to add "Browse for folder" function to this code. So, that user can choose which folder contain the source workbooks. Please help.
Sub Merge2MultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFileName As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Jude" ' change to suit
Set wbDst = Workbooks.Add(xlWBATWorksheet)
strFileName = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFileName) = 0 Then Exit Sub
Do Until strFileName = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFileName)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbDst.Worksheets(wbDst.Worksheets.Count).Name = strFileName
wbSrc.Close False
strFileName = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I tried the code below. But it gives error. Please look.
Function GetFolder(strPath As String, fldSt As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = fldSt
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub Getsheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFileName As String
Path = GetFolder("C:\", "Select an Input Folder") & Application.PathSeparator
Set wbDst = Workbooks.Add(xlWBATWorksheet)
strFileName = Dir(Path & "*.xls?")
Do While Filename <> ""
Set wbSrc = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbDst.Worksheets(wbDst.Worksheets.Count).Name = strFileName
wbSrc.Close False
strFileName = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Include:
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
and then in your Sub
MyPath = GetFolder
as a replacement for:
MyPath = "C:\Jude" ' change to suit