Excel 2010 macro is causes Microsoft Excel has Stopped working

[Liz_I3]

Hi I am working with excel 2010 and 2007. The below code works, but when I run it in 2010 after the macro has finished running I get and error message Microsoft Excel has Stopped working and excel closes. If I comment our Application.DisplayAlerts = False it works.

One other issue is that when I open the newly created excel workbook the ShowPivotTableFieldList pops up even though I have stated ActiveWorkbook.ShowPivotTableFieldList = False

Thanks in advance for assistance
L

Sub SaveAllSheetsExcel()
Dim wbk As Workbook
Dim wsh As Worksheet, vWshs
Set wbk = ActiveWorkbook
Dim newfol As String
Dim MthlyFol As String

On Error GoTo Handler

MthlyFol = Format(Date, "MMM")
newfol = Format(Date, "MMM DD YY")

'objXL.Application.DisplayAlerts = False

Application.DisplayAlerts = False
Application.ScreenUpdating = False

If Dir("\\myserver\mydirectory\ExcelDailyReports\" & MthlyFol & "\", vbDirectory) = "" Then
MkDir "\\myserver\mydirectory\ExcelDailyReports\" & MthlyFol
End If
If Dir("\\myserver\mydirectory\ExcelDailyReports\" & MthlyFol & "\" & newfol & "\", vbDirectory) = "" Then
MkDir "\\myserver\mydirectory\ExcelDailyReports\" & MthlyFol & "\" & newfol
End If

For Each wsh In wbk.Worksheets
If IsError(Application.Match(wsh.Name, vWshs, 0)) Then
wsh.Copy

ActiveWorkbook.SaveAs "\\myserver\mydirectory\ExcelDailyReports\" & MthlyFol & "\" & newfol & "\" & wsh.Name & " " & Format(Date, "MMM DD YY") & ".xls", FileFormat:=56
ActiveWorkbook.ShowPivotTableFieldList = False
ActiveWorkbook.Connections("PowerPivot Data").Delete
ActiveWorkbook.Close


End If
Next wsh

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox ("All Worksheets have been Saved as Compatibility Mode .xls Files")

Exit Sub
Handler:
'ActiveWorkbook.Close SaveChanges:=False
Resume Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[wigi]

I don't see a way of solving this without seeing it all in front of me, but here's improved coding:

Sub SaveAllSheetsExcel()
    Dim wsh As Worksheet
    Dim newfol As String
    Dim MthlyFol As String

    On Error GoTo Handler

    MthlyFol = Format(Date, "MMM")
    newfol = Format(Date, "MMM DD YY")

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    c0 = "\\myserver\mydirectory\ExcelDailyReports\" & MthlyFol & "\"
    If Dir(c0, vbDirectory) = "" Then MkDir c0
    
    c0 = c0 & newfol & "\"
    If Dir(c0, vbDirectory) = "" Then MkDir c0
    
    For Each wsh In ActiveWorkbook.Worksheets
        If IsError(Application.Match(wsh.Name, vWshs, 0)) Then
            
            wsh.Copy
            With ActiveWorkbook
                .SaveAs c0 & wsh.Name & " " & newfol & ".xls", FileFormat:=56
                .ShowPivotTableFieldList = False
                .Connections("PowerPivot Data").Delete
                .Close
            End With

        End If
    Next

    Application.DisplayAlerts = True

    MsgBox "All Worksheets have been Saved as Compatibility Mode .xls Files"

    Exit Sub
    
Handler:
    
    'ActiveWorkbook.Close SaveChanges:=False
    Resume Next
    Application.DisplayAlerts = True
    
End Sub

Please can you use

 tags here? Thanks.

 

[Liz_I3]

Thanks for the code Wigi, it worked but excel 2010 still stopped and closed after the code finished executing. Very starange it does produce the new files correctly but then crashes. It worked perfectly with no issues in 2007.

L