I am having trouble getting the below code to work. I am trying to convert cells in all excel worksheets populated in a folder using general function Range. Value = Range . Text. The formula works if I input just (Code 1) in one excel file. However, if I incorporate this code into the VBA code (2), to perform the routine for all excel files in a folder I am getting an error.
CODE 1)
Sub Test23()
Dim rng As Range: Set rng = Application.Range("B11:G200")
Dim cel As Range
For Each cel In rng.Cells
With cel
cel.Value = cel.Text
End With
Next cel
End Sub
CODE 2)
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim rng As Range
Dim cel As Range
'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
Set rng = Worksheets(1).Range("B11:G200")
For Each cel In rng.Cells
With cel
cel.Value = cel.Text
End With
Next cel
'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
This one is an easy fix. If this works for you, you can click on the check mark next to this answer to accept it as an answer.
Your code will work well if you make a few minor tweaks:
First, in CODE 2), you forgot to add the else statement to your If. This meant that your code never actually did anything with the myPath variable, even if the user chose a folder. Because myPath was always empty, your code did exactly what you wanted it to do: GoTo ResetSettings. I added an ElseIf condition for you with a comment to explain it.
Second, if you ever change a UI setting via VBA, make sure you error trap to reset those settings in case something goes wrong. I added an On Error statement at the top of your code to make sure you never leave your users stranded -- even if you're the user!
Good luck, and don't forget to accept this as an answer if it works for you!
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim rng As Range
Dim cel As Range
On Error GoTo ErrHandler 'added this so that if something breaks, you remember to reset the screenupdating
'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 'if other than -1, user hit cancel so go to NextCode to kick off the resetsettings (this seems redundant, why not go directly to ResetSettings?)
ElseIf .Show = -1 Then 'this could also be a simple Else with no condition attached; I tend to use ElseIf with a specific condition to make sure I get exactly what I want
myPath = .SelectedItems(1) & "\" 'if user hit the action button, add it to myPath -- your earlier code skipped this part because there was no else statement
End If
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings 'before the change I made above, you would always jump right to 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
Set rng = Worksheets(1).Range("B11:G200")
For Each cel In rng.Cells
With cel
cel.Value = cel.Text
End With
Next cel
'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
Exit Sub 'exit the sub if we got this far without an error so that we don't run the error handler unless there is an error
ErrHandler:
MsgBox ("Sorry, something went wrong. The error code was " & Err.Number & " on line: " & Erl) 'tell the user what went wrong
GoTo ResetSettings 'cleanup
End Sub
Related
This question already has answers here:
how to detect whether VBA excel found something?
(3 answers)
Closed 1 year ago.
I'm trying to run a macro that does three things:
Loops through a series of excel files
Identifies a row containing the text "project attributes"
Uses this row to set a range to perform a merge operation
I constructed this out of building blocks of code I found elsewhere, and I know that each works independently (i.e. I can run through all files without performing actions, and I can identify the row and perform the merge) but when I combine them, I get a run-time 91 error "Object variable or With Block variable not set" - associated with this line " FindRowNumber = FindRow.Row ".
Looking for guidance as to how I can avoid having this variable set to "Nothing" as it appears in the Watches window.
Thanks!
'''
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 = "*.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
'Change First Worksheet's Background Fill Blue
wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
Call RowStart(wb)
'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
Sub RowStart(wb As Workbook)
Dim FindRowNumber As Long, FindRowStart As Integer, FindRow As Range
With wb.Worksheets("Project Details")
Set FindRow = .Range("A:A").Find(What:="Project Attributes", LookIn:=xlValues, LookAt:=xlWhole)
End With
FindRowNumber = FindRow.Row
FindRowStart = FindRowNumber + 1
'MsgBox FindRowStart
Call vba_merge(FindRowStart, wb)
End Sub
As noted in comments - you need to account for your Find not getting a match:
Sub RowStart(wb As Workbook)
Dim FindRow As Range
With wb.Worksheets("Project Details")
Set FindRow = .Range("A:A").Find(What:="Project Attributes", _
LookIn:=xlValues, LookAt:=xlWhole)
End With
If Not FindRow Is Nothing Then
vba_merge FindRow.Row + 1, wb 'use of `Call` is outdated....
Else
MsgBox "Row not found in workbook '" & wb.Name & "'", vbExclamation
End If
End Sub
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'm trying to save time in looking for excel files without a specific sheet named "RUNREADY" in a large directory of nested folders and excel files. This workbook without the worksheet would ideally be listed in a master excel file higher up in the directory or just have its name changed to end in a '(1)' or '(0)' depending on if it has the sheet or not.
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 = "*.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
'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
Dim ws As Worksheet
Dim rr As Integer
Dim cel As Range
rr = 0
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "RUNREADY" Then
rr = rr + 1
Else
rr = 0
End If
Next ws
If rr = 1 Then
[RUNREADY.xlsm] Sheet1!cel.Value = ActiveWorkbook.FullName
[RUNREADY.xlsm] Sheet1!cel.Offset(1, 0)
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
End Sub
I looked around for some sort of guidance and found this piece of code that searches through a file. I tried to write something that would write to a named excel file. my portion is spaced off in the middle of everything Running this i get an error at the first square bracket in my portion of code.
Im trying to copy data from a whole bunch of different workbooks into one master sheet, pasting just the values in the next blank column. It all seems to be functional but always fails when it attempts to paste into the master sheet. I've tried looking at similar problems elsewhere but i cant seem to get them to work with what I am trying to do.
I have grabbed the bulk of this code off somewhere else and modified to suit, as you may be able to tell from some of the left over comments
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 colDest As Long
Dim Dest As Worksheet
'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
'Change First Worksheet's Background Fill Blue this is where the work occurs
Set Dest = Workbooks("Master.xlsm").Worksheets(1)
colDest = Dest.Cells(1, Dest.Columns.Count).End(xlToRight).Column
wb.Worksheets(1).Range("b3:u83").Copy
Dest.Range(1, colDest).PasteSpecial Paste:=xlPasteValues
'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: Error occurs on this line:
Dest.Range(1, colDest).PasteSpecial Paste:=xlPasteValues
Run-time error '1004':
Method 'Range' of object '_Worksheet' failed.
EDIT2: Changing the attempt to Paste with an attempt to write a value to the cell ie:
Dest.Cells(1, colDest) = "Test"
Correctly types "Test" into the next available column on the master sheet for every workbook that was opened from the directory.
Apparently changing 'Range' to 'Cells' works, which i thought i tried yesterday but was throwing a different error complaining i wasn't selecting the correct size cell
Try this basically what you need to do is add 1 to the colDest to give you the next empty column.
Sub LoopAllExcelFilesInFolder()
'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 FldrPicker As FileDialog
Dim colDest As Long
Dim Dest As Worksheet
'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
'Change First Worksheet's Background Fill Blue this is where the work occurs
Set Dest = Workbooks("Master.xlsm").Worksheets(1)
colDest = Dest.Cells(1, Dest.Columns.Count).End(xlToLeft).Column + 1
wb.Worksheets(1).Range("b3:u83").Copy
Dest.Range(1, colDest).PasteSpecial Paste:=xlPasteValues
'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
Below are some guidelines on how to find last column an import value after last column.
Option Explicit
Sub Test()
Dim LastColumn As Long
With ThisWorkbook.Worksheets("Sheet1")
'Last Column using UsedRange (NOT A GOOD IDEA)
LastColumn = .UsedRange.Columns(.UsedRange.Columns.Count).Column
'Last Column using specific row 7
LastColumn = .Cells(7, .Columns.Count).End(xlToLeft).Column
'Add a value in row 5 & after last column
.Cells(5, LastColumn + 1).Value = ""
End With
End Sub
Set Dest = Workbooks("Master.xlsm").Worksheets(1)
colDest = Dest.Cells(1, Dest.Columns.Count).End(xlToLeft).Column + 1
wb.Worksheets(1).Range("b3:u83").Copy
Dest.Cells(1, colDest).PasteSpecial Paste:=xlPasteValues
Correctly inputs the Data where I need it, the 'ToLeft' made a difference but 'Range' wouldn't allow me to paste where 'Cells' does
Here is my working code, I just want user to prompt for tab name, so that user can pick which tab to delete:
Sub LoopAllExcelFilesInFolder()
'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 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)
'Change First Worksheet's Background Fill Blue
'wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
wb.Worksheets(2).Delete
'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
Add these variables (or similar) to the top of your code.
Dim DelSheet as string
Dim sht as worksheet
Get the sheet name - this is an example, you can get it from the user however you want
DelSheet = InputBox(Prompt:="Enter the name of the sheet to delete")
Modify this portion of your code, above. Leave the rest as is, since it seems to be working ok.
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'this loop isn't particularly efficient, but it prevents attempting
'deletion of the sheet if that sheet doesn't exist in the wb
'you could wrap the code in an "On Error..." block instead
for each sht in wb.sheets
if sht.name = DelSheet then
wb.Worksheets(DelSheet).Delete
endif
next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
FreeMan's answer one step further (with multiple sheets to be deleted).
New variables
Dim DelSheets() As String 'array
Dim intDelSheetCount As Integer
Dim DelSht As Variant
New loop for user promt
'ask user multiple times, which sheets he wants to delete
Do
ReDim Preserve DelSheets(intDelSheetCount)
DelSheets(intDelSheetCount) = InputBox(Prompt:="Enter the name of the sheet to delete")
intMsgBoxAnswer = MsgBox("Do you want to type more sheets to be deleted?", vbYesNo)
intDelSheetCount = intDelSheetCount + 1
Loop While intMsgBoxAnswer = 6 'while the answer is YES
Deletion loop
For Each sht In wb.Sheets
For Each DelSht In DelSheets
If sht.Name = DelSht Then
DelSht.Delete
End If
Next DelSht
Next
Additional settings
To get rid of the Excel popup question, if you are super sure if you want to delete the sheet, you can use Application.DisplayAlerts = False at the beginning of the sub.