Delete multiple columns in multiple Excel files present in a folder - vba

I had tried this code for one excel sheet.
Sub sbVBS_To_Delete_Multiple_Columns ()
Columns("A:C").EntireColumn.Delete
End Sub
This worked well for one excel sheet in the folder, I want to loop through all the excel files in that folder and do it in one go, any help is appreciated.
After adding the logic of traversing through all the files in the folder
​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
'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)
wb.Worksheets(1).Columns("A:B").EntireColumn.Delete
'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
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Problem is Compatibility checker, have to disable that.

Related

Loop through all excel workbooks in a folder and convert all formulas to values

I am looking for a VBA code that would allow me to loop through all the Excel workbooks in a certain folder, and for each workbook will convert the cells in each worksheet from formulas to values.
Use the following code which loops through all the workbooks in a user-specified folder and does the following:
It opens the workbook
It loops within each worksheet in the workbook (including hidden worksheets), and converts to values every cell that contains a formula.
After performing the conversion, it saves and closes the workbook, and moves on to the next workbook in the folder.
See code below:
Sub LoopAllExcelFilesInFolderCancelFormulas()
'Purpose: To loop through all Excel files in a user specified folder and convert all formulas to values
Dim wb As Workbook
Dim ws As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Disable Excel Pop-up messages:
Application.DisplayAlerts = False
'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
For Each ws In wb.Sheets
ws.UsedRange.Value = ws.UsedRange.Value
Next
'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.DisplayAlerts = True
End Sub
The code for looping through all workbooks in a certain folder is based on the following code.

Excel VBA: In a loop, why am I losing my active workbook when I evaluate another sub?

I am modifying a function for looping through all workbooks in a folder and performing an action on each.
In the code below, if I un-comment the Module1.TestSub line, the loop performs TestSub on each file in the chosen folder, as expected.
But I want it to work as a function, taking another sub or function as it's argument and performing that on the loop, so that I could run LoopThroughWorkbooks (Module1.TestSub) and not have to edit LoopThroughWorkbooks every time I want to loop a different action.
If I instead un-comment the Evaluate (myAction) line, it seems to still loop through the intended files doing nothing, and performs Module1.TestSub on the file I had active to begin with.
It seems like the Evaluate (myAction) line is losing track of the workbook opened by the loop in a way that doesn't happen when I just explicitly call Module1.TestSub.
Function LoopThroughWorkbooks(myAction As String)
'PURPOSE: To loop through all xls* files in a user specified folder and perform an action
'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
'Do Action Specified in Argument
'Module1.TestSub <<<<<<<<<<<<<<<< This line works
'Evaluate (myAction) <<<<<<<<<<<<<<<< This line doesn't
'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 "Looping Complete!"
'Reset Macro Optimization Settings
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Function
And in case it's helpful, here's Module1.TestSub:
Function TestSub()
Range("A1") = "AAA"
End Function
And here's how I'm calling it:
Sub runtest()
Module2.LoopThroughWorkbooks (Module1.TestSub)
End Sub

Use file picker to find specific documents then copy and paste

After I find the file paths I want to be able to copy data from six to seven of the workbooks selected and then paste them all into the active file. Any help getting me started from here would be great.
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

VBA Looping through excel files in selected directory - Copy data and paste in different sheets

I'm looking to select a directory and then loop through each xlsm file within that directory. For each loop it should open the file, copy a range and paste into the current workbook under a specific sheet.
I.e. the first file will paste into sheet1 the second opened file will past into sheet 2, and so on.
I have some code, now I need help to get it to paste the rang into a sheets.count? or something like that. At the moment it just pastes into sheet 1 because that is static.
Sub Test()
Dim wb As Workbook, wb1 As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set wb1 = Workbooks(ThisWorkbook.Name)
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 = "*.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
'Copy data from opened workbook
wb.Sheets("HI Sub-segment split").Range("A1:Z1").Copy
'Paste data into destination workbook
wb1.Sheet(1).Range("A1:Z1").PasteSpecial xlPasteValues
'Close Workbook
wb.Close
'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 "Import Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Worked with this...
Sub Testing()
'
'
'
Dim wb As Workbook, wb1 As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim loop_ctr As Integer
Set wb1 = Workbooks(ThisWorkbook.Name)
loop_ctr = 1
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
'Copy data from opened workbook
wb.Sheets("Sheet1").Range("A1:B2").Copy
'Paste data into destination workbook
wb1.Sheets(loop_ctr).Range("A1:B2").PasteSpecial xlPasteValues
'Close Workbook
wb.Close
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
'Update loop_ctr value
loop_ctr = loop_ctr + 1
Loop
'Message Box when tasks are completed
MsgBox "Import Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Grabbing data from multiple excel files and copy them in a summary sheet

Whenever I run this code I get: Run-time error '9' Subscript out of range. Can't figure out how to fix this error, please help.
The code runs trough excel files in a selected folder and copy pastes the selected row.
In the next step I would like to extend the code, to store and sum each cell value like this:
var1 = var1 + range("A5").value
But first please help me how to fix this error. Thank you.
Sub LoopAllExcelFilesInFolder()
Dim OutputWs As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Lastrow As Long
'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
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'set output worksheet
OutputWs = ThisWorkbook.Worksheets(Test)
'Loop through each Excel file in folder
Do While myFile <> ""
Workbooks.Open (myPath & myFile)
Range("A1:D3").Copy
ActiveWorkbook.Close
Lastrow = OutputWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Test").Range(Cells(Lastrow, 1), Cells(Lastrow, 4))
'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
To set an object reference to your worksheet, you need the keyword Set included:
Set OutputWs = ThisWorkbook.Worksheets("yoursheetname")
The get next file name should also be myFile = Dir and not include the parenthesis.
I took a closer look at the code and it appears that you're not explicitly defining which books are which in each case, meaning that the "orphaned" range statements can cause you problems. The 1004 error though is coming from your Paste statement, which I have corrected for you in the following code:
Sub LoopAllExcelFilesInFolder()
Dim OutputWs As Worksheet
Dim oNewBook As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Lastrow As Long
'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
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'set output worksheet
Set OutputWs = ThisWorkbook.Worksheets("Test")
'Loop through each Excel file in folder
Do While myFile <> ""
Set oNewBook = Workbooks.Open(myPath & myFile)
oNewBook.Worksheets(1).Range("A1:D3").Copy
oNewBook.Close
Lastrow = OutputWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With OutputWs
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
OutputWs.Paste .Range("A" & Lastrow & ":" & "D" & Lastrow)
End With
'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
Note that this code assumes that you want to copy from the first worksheet of the opened workbook (hence the oNewBook.Worksheets(1) added to the Range.Copy statement)