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
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).
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 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
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.