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!
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 have a problem with a macro, I have a sample file with a button that I would like to use to run two files in the background. One wb = this is a template and wbMe pli with data that I would like to copy to wbMe. However, when I run the code, I get subcprite out of range. Where I have an error, such a sheet exists + there is data there in the cell
Sub COREP_ITS()
Dim strPath As String
Set wb = ThisWorkbook
Set wbMe = ThisWorkbook
strPath = selectFile
If strPath = "" Then Exit Sub
Set wbMe = ThisWorkbook
MyFolder = "sample_folder"
MyFile = Dir(MyFolder & "\CMR - CJ_MINIMAL*.xlsx")
If MyFile <> "" Then
Set wb = Workbooks.Open(MyFolder & "\" & MyFile, UpdateLinks:=0)
Else
Exit Sub
End If
''C_0700_002''
wbMe.Sheets("Tabela_COREP").Range("F14").Copy
wb.Sheets("C_0700_0002").Range("G14").PasteSpecial Paste:=xlPasteValues
End Sub
Private Function selectFile()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = ActiveWorkbook.Path
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel", "*.xlsx"
If .Show = True Then selectFile = .SelectedItems(1)
End With
End Function
You don't open the user-selected file.
You need to pass strPath to Workbooks.Open
strPath = selectFile
If strPath = "" Then Exit Sub
Set wbMe = Workbooks.Open(strPath)
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
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 unmerge and duplicate data for a folder of xlsx files.
Separately, both macros work as intended. When I combine the macros (through "Call"), it executes but then brings me back to the macro screen. It doesn't give me any errors, but I need to close excel to start over.
I'm guessing the "UnMergeFill" macro isn't playing nice with being opened automatically?
I've tried using "call" and also with just the name of the sub. I've also tried separating the subs into different modules.
Sub AllWorkbooks()
Dim MyFolder As String
Dim MyFile As String
Dim wbk As Workbook
On Error Resume Next
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.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)
UnMergeFill
wbk.Close savechanges:=True
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Call Sub UnMergeFill()
Dim cell As Range, joinedCells As Range
For Each cell In ThisWorkbook.ActiveSheet.UsedRange
If cell.MergeCells Then
Set joinedCells = cell.MergeArea
cell.MergeCells = False
joinedCells.Value = cell.Value
End If
Next
End Sub
'''
Try This:
Sub AllWorkbooks()
Dim MyFolder As String
Dim MyFile As String
Dim wbk As Workbook
On Error Resume Next
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.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)
Call UnMergeFill(wbk)
wbk.Close savechanges:=True
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Sub UnMergeFill(wb As Workbook)
Dim cell As Range, joinedCells As Range
For Each cell In wb.ActiveSheet.UsedRange
If cell.mergeCells Then
Set joinedCells = cell.MergeArea
cell.mergeCells = False
joinedCells.Value = cell.Value
End If
Next
End Sub