Problem with Folder Picker

[zenjah]

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]

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]

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]

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]

I changed the thread title to "Problem with Folder Picker"