EXCEL VBA執行後無法存檔

一個整理報表的VBA可以正常執行但執行後無法存檔，存檔或另存新檔會造成EXCEL崩潰強制關閉所有EXCEL檔案，如果VBA執行後放著不存檔也會不定時觸發崩潰，崩潰後會再存檔路徑留下0KB檔案。以下是VBA代碼，需要範例報表的話也可以提供

Option Explicit

Public Sub RunFormatAndSortData()

    Call FormatAndSortData

End Sub

Private Sub FormatAndSortData()

    Dim lastRow As Long

    Dim startRow1 As Long, endRow1 As Long

    Dim startRow2 As Long, endRow2 As Long

    Dim startRow3 As Long, endRow3 As Long

    lastRow = Me.Cells(Me.Rows.Count, "S").End(xlUp).Row

    ' 1. 選取範圍 A 欄=>> Group Value Unavailable:S 欄最後一筆有資料的格子=無框線

    With Me.Range("A1:S" & lastRow)

        .Borders.LineStyle = xlNone

        .Font.Bold = False

    End With

    ' 2. A 欄=>> Group Value Unavailable往下第一個空格的列

    startRow1 = Me.Columns("A").Find(">> Group Value Unavailable", LookAt:=xlWhole).Row + 1

    endRow1 = FindNextEmptyRow(startRow1)

    ' 格式調整第一個空格行加入上框線+粗體字

    With Me.Range("A" & endRow1 & ":S" & endRow1)

        .Borders(xlEdgeTop).LineStyle = xlContinuous

        .Font.Bold = True

    End With

    ' 4. A 欄=L往下第一個空格的列

    startRow2 = Me.Columns("A").Find("L", LookAt:=xlWhole).Row + 1

    endRow2 = FindNextEmptyRow(startRow2)

    Me.Cells(endRow2, "A").Value = "LONG TOTAL"

    With Me.Range("A" & endRow2 & ":S" & endRow2)

        .Borders(xlEdgeTop).LineStyle = xlContinuous

        .Font.Bold = True

    End With

    ' 5. A 欄=S往下第一個空格的列

    startRow3 = Me.Columns("A").Find("S", LookAt:=xlWhole).Row + 1

    endRow3 = FindNextEmptyRow(startRow3)

    Me.Cells(endRow3, "A").Value = "SHORT TOTAL"

    With Me.Range("A" & endRow3 & ":S" & endRow3)

        .Borders(xlEdgeTop).LineStyle = xlContinuous

        .Font.Bold = True

    End With

    ' 6. G,H,I,L,M,O,P,Q行中，被調整成粗體的列加入SUM公式效果=ALT+=的加總

    AddSumFormula "G", endRow1

    AddSumFormula "H", endRow1

    AddSumFormula "I", endRow1

    AddSumFormula "L", endRow1

    AddSumFormula "M", endRow1

    AddSumFormula "O", endRow1

    AddSumFormula "P", endRow1

    AddSumFormula "Q", endRow1

    AddSumFormula "G", endRow2

    AddSumFormula "H", endRow2

    AddSumFormula "I", endRow2

    AddSumFormula "L", endRow2

    AddSumFormula "M", endRow2

    AddSumFormula "O", endRow2

    AddSumFormula "P", endRow2

    AddSumFormula "Q", endRow2

    AddSumFormula "G", endRow3

    AddSumFormula "H", endRow3

    AddSumFormula "I", endRow3

    AddSumFormula "L", endRow3

    AddSumFormula "M", endRow3

    AddSumFormula "O", endRow3

    AddSumFormula "P", endRow3

    AddSumFormula "Q", endRow3

    ' 7. 選取A=>> Group Value Unavailable下一列到第一列粗體字以上的資料進行排序

    SortByKeysCustom Me.Range("A" & (startRow1) & ":S" & (endRow1 - 1))

    ' 8. 選取A=L下一列到LONG TOTAL以上的資料進行排序

    SortByKeysCustom Me.Range("A" & (startRow2) & ":S" & (endRow2 - 1))

    ' 9. 選取A=S下一列到SHORT TOTAL以上的資料進行排序

    SortByKeysCustom Me.Range("A" & (startRow3) & ":S" & (endRow3 - 1))

    MsgBox "資料已整理並排序完成"

End Sub

Private Sub SortByKeysCustom(rng As Range)

    ' 定義排序順序

    Dim orderA As Variant

    orderA = Array("TW$D", "JP$Y", "KR$W", "SG$D", "CN$Y", "HK$D", "US$D", "GB$P", "CH$F", "EU$R", "SE$K")

    Dim orderB As Variant

    orderB = Array("CFD", "EQTY", "POPT", "COPT")

    Dim arr(1) As Variant

    arr(0) = orderA

    arr(1) = orderB

    With Application

        .ScreenUpdating = False ' 關閉螢幕更新以加快運行速度

        ' 先對 C 列進行按 A 到 Z 排序

        rng.Sort Key1:=rng.Columns(3), Order1:=xlAscending, Header:=xlNo

        ' 按照自定義順序排序 A 列和 B 列

        Dim i As Integer, n As Integer

        For i = 0 To 1

            .AddCustomList ListArray:=arr(i)

            n = .GetCustomListNum(arr(i))

            rng.Sort Key1:=rng.Columns(i + 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=n + 1

            .DeleteCustomList ListNum:=n

        Next i

        .ScreenUpdating = True ' 恢復螢幕更新

    End With

End Sub

Private Sub AddSumFormula(col As String, sumRow As Long)

    Dim startRow As Long

    startRow = Me.Cells(sumRow, col).End(xlUp).Row

    Me.Cells(sumRow, col).Formula = "=SUM(" & col & startRow & ":" & col & (sumRow - 1) & ")"

End Sub

Private Function FindNextEmptyRow(startRow As Long) As Long

    Dim i As Long

    For i = startRow To Me.Rows.Count

        If IsEmpty(Me.Cells(i, "A")) Then

            FindNextEmptyRow = i

            Exit Function

        End If

    Next i

    FindNextEmptyRow = Me.Rows.Count

End Function