I am wondering if there are any experts that can have a look and advise what I am doing wrong with the codes below. I've adapted and modified the codes from TheSpreadsheetGuru which basically opens up all the Excel spreadsheets in a given folder and copy/paste the information into the master spreadsheet.
If I open my master spreadsheet and run the macro it actually works fine. However, if I clear the contents in the master spreadsheet first or run the macro more than once then Excel would just shut itself down - I can't see anything that's obviously wrong with the codes so would appreciate any help if you can tell me what I am doing wrong
Thanks in advance
Sub SI_Report()
'PURPOSE: To copy strategic initiatives report into the master table
'SOURCE: Codes here are modified based on codes obtained from TheSpreadsheetGuru.com
Check = MsgBox("This will copy all the strategic initiatives from spreadsheets stored in a folder you will now choose, are you sure?", vbOKCancel)
If Check = vbOK Then
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimise Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
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
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
' Clear contents first
Windows("Strategic Initiatives Master.xlsm").Activate
Sheets("Strategic Initiatives").Select
Range("A2:W201").Select
Selection.ClearContents
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile, UpdateLinks:=0)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Copy data
wb.Sheets("Strategic Initiatives").Select
Range("A2", Range("W2").End(xlDown)).Select
Selection.Copy
'Paste data
Windows("Strategic Initiatives Master.xlsm").Activate
Sheets("Strategic Initiatives").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Close Workbook without Saving
wb.Close SaveChanges:=False
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
Sheets("Instruction").Select
ResetSettings:
'Reset Macro Optimisation Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Else: Exit Sub
End If
End Sub
Try using Option Explicit to make sure all the variables have been declared
Related
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.
I have written a macro below to copy and paste data from all workbooks within a user selected folder into a master document, however currently the macro selects the files in a random order. What I want to do is for it to select the files in alphabetical order, so the data in the master document is in the correct order... Help achieving this would be much appreciated, I am not precious about the method!
Sub Import_Data()
' PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim WB As Workbook
Dim wbThis As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set wbThis = ActiveWorkbook
' Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Retrieve Target Folder Path From User
MsgBox "Please select Faro Scan Data Folder"
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 target workbook....
WB.Activate
Application.CutCopyMode = False
Range("D8:D377").Copy
wbThis.Activate
Sheets("Faro Scan Data").Select
Range("E5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
' Insert column for next data set
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
' Format column for new dataset
Columns("I:I").Select
Selection.Copy
Columns("E:E").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' Close Workbook
WB.Close SaveChanges:=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
MsgBox "Remeber to enter column headings!"
End Sub
Take a look at the below example showing how you can loop through files in folder with filter and sorted in alphabetical order using Shell.Application ActiveX:
Option Explicit
Sub Test_Shell_Folder_Items()
Dim sPath
Dim sExtension
Dim oShellApp
Dim oFolder
Dim oFolderItems
Dim oFolderItem
sPath = "C:\Test"
sExtension = "*.xls"
Set oShellApp = CreateObject("Shell.Application")
Set oFolder = oShellApp.Namespace(sPath)
Set oFolderItems = oFolder.Items()
oFolderItems.Filter 64 + 128, sExtension ' 32 - folders, 64 - not folders, 128 - hidden
For Each oFolderItem In oFolderItems
Debug.Print oFolderItem.Path
Next
End Sub
I have a folder containing nearly 1,000 .csv files. I would like to grab the second column from each of these files and transpose-paste them into a new Excel workbook, so that the data is in one row.
The following is what i have so far:
Sub OpenFiles2()
Dim MyFolder As String
Dim MyFile 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
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Do While myPath <> ""
Range(Range("B1"), Range("B1").End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
ActiveWorkbook.Close True
Windows("Compiled.xlsm").Activate
Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1,0).PasteSpecial Transpose:=True
MyFile = Dir
Loop
End Sub
For some reason I keep getting an error for the Paste Special command.
I also tried to replace it with:
ActiveSheet.PasteSpecial Transpose:=True
And
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= False, Transpose:=True
Still got errors. Please help. Thank you.
I would avoid using select and deal with the values. This code stores the original value in a variable, then you can close the active workbook and use the data in that variable by using the Application.Transpose within VBA.
Replace the Do Loop with the below code.
Do While myPath <> ""
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
x = Range("B1:B" & lastrow).Value
ActiveWorkbook.Close True
With Worksheets("Sheet1")
Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1). _
Resize(, lastrow).Value = Application.Transpose(x)
End With
MyFile = Dir
Loop
Sub Button3_Click()
'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 = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set newWb = Workbooks.Add
With newWb
.SaveAs Filename:=myPath & Left(myFile, 5) & "_import.xlsx"
End With
'Loop through each Excel file in folder
i = 2
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Set newWb = Workbooks.Open(Filename:=myPath & Left(myFile, 5) & "_import.xlsx")
'Change First Worksheet's Background Fill Blue
wb.Sheets("Textual elements").Range("J11").Copy _
Destination:=newWb.Sheets("Sheet1").Cells(i, 1)
wb.Worksheets("Textual elements").Range("J31").Copy _
Destination:=newWb.Worksheets("Sheet1").Cells(i, 2)
i = i + 1
'Save and Close Workbook
newWb.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
So I took the code from below site tried to edit according to my needs, but I get error italicized row in debugging mode.
The intention is to open a new workbook named as selected the folder and copy the cells to specific cells.
http://www.thespreadsheetguru.com/the-code-vault/2014/4/23/loop-through-all-excel-files-in-a-given-folder
The Range-object does not have a Paste method, so it cannot identify the Paste statement. Hence the error. You can use PasteSpecial though.
Try this:
replace:
wb.Worksheets("Textual elements").Range("J11").Copy
newWb.Worksheets("Sheet1").Range(Cells(i, 1)).Paste
wb.Worksheets("Textual elements").Range("J11").Copy
newWb.Worksheets("Sheet1").Range(Cells(i, 2)).Paste
with:
wb.Worksheets("Textual elements").Range("J11").Copy
newWb.Worksheets("Sheet1").Range(Cells(i, 1),Cells(i,2)).PasteSpecial
or without PasteSpecial:
wb.Worksheets("Textual elements").Range("J11").Copy newWb.Worksheets("Sheet1").Range(Cells(i, 1),Cells(i,2))
or even, if you must use Paste ;-):
wb.Worksheets("Textual elements").Range("J11").Copy
newWb.Worksheets("Sheet1").Range(Cells(i, 1),Cells(i,2)).select
ActiveSheet.Paste
I am still using Excel2002 so it doesn't play nice with xlsx files all the time. That said, you may not need the line
set newWb = Workbooks.Open(Filename:=myPath & Left(myFile, 5) & "_import.xlsx")
as I believe the workbook should open when it is added (possibly different in new versions).
When it comes to copying the range from one workbook to another
wb.Worksheets("Textual elements").Range("J11").Copy Destination:=newWb.Worksheets("Sheet1").Range(Cells(i, 1))
I am not sure if you have the Do While myFile <> "" loops set properly. You are ensuring myFile <> "" then doing something but not changing myFile's value and checking again that myFile <> ""
Also if you run this macro, it will overwrite the specified cells each time it is run so you will only have the most recent data - just incase that's not what you're trying to do.
EDIT
I still don't think you need to open the newwb when you have just opened it - might be best to step through the code using F8 & F9 to test that.
With regards the copying, I was right that you should use copy : destination, but hadn't noticed you were trying to range a cell. It should be either Range() OR cell(). Try this:
wb.Sheets("Textual elements").Range("J11").Copy _
Destination:=newWb.Sheets("Sheet1").Cells(i, 1)
wb.Worksheets("Textual elements").Range("J31").Copy _
Destination:=newWb.Worksheets("Sheet1").Cells(i, 2)
The space underscore ' _' at the end of copy is just to take the codee to a new line for ease of reading (so it doesn't go off the end of the page)
At the end of your code you are closing wb and saving changes even though you have not made any changes. I would change this to newwb and close wb without saving changes.
I am using a macro that opens each excel file in the same folder that the workbook containing the macro (I'll call it the master workbook) is in and copies all the data in the first spreadsheet, then pastes them into the master workbook on a new worksheet. I found some very useful code online that I made a few changes to. Everything seems to be working fine, except that while this code is opening each file in the folder (in the Do Until loop), it opens itself half way through.
I'd like to be able to avoid this without referencing the master spread sheet's name directly, in case someone renames it.
Is there a simple command that will make skip the remaining code in the loop if it tries to open itself?
Code is below:
Sub CombineWSs()
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 = ThisWorkbook.Path
Set wbDst = ThisWorkbook
strFilename = Dir(MyPath & "\*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
'copy the data
wbSrc.ActiveSheet.UsedRange.Select
Selection.Copy
'create a new worksheet in this master file
wbDst.Sheets.Add After:=Sheets(Sheets.Count)
'paste the data into master file's new sheet
wbDst.Sheets(wbDst.Worksheets.Count).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Put an If block inside our loop
Do Until strFilename = ""
If strFilename <> wbDest.Name Then 'since you already set wbDest = ThisWorkbook
'... rest of code
End If
Loop