PDA

View Full Version : Problem with Folder Picker



zenjah
01-19-2017, 01:38 PM
Hi there, 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 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 with this

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

SamT
01-19-2017, 09:20 PM
Suggestions:

If Check <> vbOK Then Exit Sub '<<<<<<<<<<<<
...
'Else: Exit Sub
'End If



With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo ResetSettings '<<<<<<<<<<<<
myPath = .SelectedItems(1) & "\"
End With



Dim DestSht As Worksheet
Set DestSht = Workbooks("Strategic Initiatives Master.xlsm").Sheets("Strategic Initiatives")

' Clear contents first
DestSht.Range("A2:W201").ClearContents

myFile = Dir(myPath & "*.xls*")
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").Range("A2", Range("W2").End(xlDown)).Copy
'Paste data
DestSht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

'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

zenjah
01-19-2017, 09:52 PM
thank you Sam for your suggestions - I will make some changes to my codes and see if it works - thanks heaps for your help

zenjah
01-23-2017, 03:07 PM
Hi Sam, thanks again for your suggested changes. It has certainly made my codes more efficient - thank you

I've run the codes again with your suggested changes (apart from the paste data part as it was throwing up errors even after I removed page protection) - again it works fine the first time I run the codes but if I run it the second time it again shuts Excel down unexpectedly. I've used F8 to step through to see which part of the codes is shutting excel down and it happens after using the folder picker to choose the folder destination. Is there anything from the folder picker that could have caused this? thanks again

SamT
01-24-2017, 04:11 AM
I changed the thread title to "Problem with Folder Picker"