Excel Crashes After Custom Sort Code

[Ark68]

I am having an interesting problem.

I have this module code below, that was of no problem whatsoever until I added the code in blue. This blue code provides a custom sort.

After I execute this module, within 10 or so minutes, Excel will crash and restart with recovered files, even if idle. I can sit and just watch without even touching my keyboard and it will crash. Sometimes I can recreate the crash by trying to save my Excel project through the VBA editor from which I'm working. This leads me to believe it has something to do with the files(s) reaction to being saved, whether formally of fr routine backup purposes?

At this point there are three workbooks open ... the main workbook holding the application code, a data source file (st_srchfn) and the module created workbook (Workbooks(ws_name)).

Is anyone able to see in my code what might be causing this and how I can fix it? How about an alternate means to do a custom sort perhaps?

With this portion of code excluded, I don't get this crashing behaviour.

Sub master_worksheet()

    Dim wb_base As Workbook, wksh_book As Workbook, newbook As Workbook
    Dim ws_core As Worksheet, ws_corestaff As Worksheet
    Dim ws_masterwksh As Worksheet, ws_vh As Worksheet, ws_wkmaster As Worksheet
    Dim qfile2 As String, st_srchfn As String, fac5 As String, crew_sig As String, crew_prep As String, crew_groom As String, crew_lon As String, crew_loff As String, crew_close As String
    Dim dir_name As String, path2 As String, ws_name As String
    Dim norec As Long, rws2add As Long, i As Long
    Dim r As Range, fac_rng As Range
    Dim CList(1 To 6) As String, sReport(1 To 8) As String

    
    Set ws_masterwksh = Workbooks("sports15b.xlsm").Worksheets("MasterWKSH")
    Set ws_vh = Workbooks("sports15b.xlsm").Worksheets("VAR_HOLD")
    Set fac_rng = Workbooks("Sports15b.xlsm").Worksheets("Facilities").Range("A:G")
    
    qfile2 = ws_vh.Range("B4")
    
    st_srchfn = "H:\PWS\Parks\Parks Operations\Sports\Sports15\DATA1\" & qfile2
    
    dir_name = Format(ws_vh.Range("B2"), "ddd dd-mmm-yy")
    path2 = "H:\PWS\Parks\Parks Operations\Sports\Sports15\WORKORDERS\" & dir_name
    ws_name = "WS " & Format(ws_vh.Range("B2"), "dd-mmm-yy") & ".xlsx"
    
    On Local Error Resume Next
    MkDir path2
    Select Case Err.Number
        Case 0
            MsgBox "created directory"
        Case 75
            MsgBox "Directory already exists"
        Case Else
            MsgBox Err.Number & " -" & Err.Description
    End Select
    
    Set wb_base = Workbooks.Open(st_srchfn)
    On Error Resume Next
    Windows(wb_base.Name).Visible = False
    On Error GoTo 0
    Set ws_core = wb_base.Worksheets("CORE")
    Set ws_corestaff = wb_base.Worksheets("Staff")

    Set newbook = Workbooks.Add
    With newbook
        .SaveAs Filename:=path2 & "\" & ws_name
    End With
    Set wksh_book = Workbooks(ws_name)
    
    With ws_masterwksh
        .Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Master"
    End With
    
    Set ws_wkmaster = wksh_book.Worksheets("Master")
    norec = WorksheetFunction.Count(ws_core.Range("C:C"))
    
    With ws_wkmaster
        .Range("M1") = ws_vh.Range("B2")
        .Range("M4") = "Min Time"
        .Range("O4") = "ALL"
        .Range("P4") = "Max Time"
        .Range("M5") = Format(WorksheetFunction.min(ws_core.Range("O:O")), "h:mmA/P")
        .Range("P5") = Format(WorksheetFunction.Max(ws_core.Range("O:O")), "h:mmA/P")
       'insert blank rows
        rws2add = norec - 1
        Set r = .Range("A13")
        Do
            .Range(r.offset(1, 0), r.offset(rws2add, 0)).EntireRow.Insert
            Set r = Cells(r.row + rws2add + 1, 1)
            If r.offset(1, 0) = "" Then Exit Do
        Loop
        
        .Range("A13:A" & norec + 12) = ws_core.Range("A2:A" & norec + 1).Value
        .Range("C13:C" & norec + 12) = ws_core.Range("C2:C" & norec + 1).Value
        .Range("E13:E" & norec + 12) = ws_core.Range("F2:F" & norec + 1).Value
        .Range("F13:G" & norec + 12) = ws_core.Range("N2:O" & norec + 1).Value
        
        .Range("H13:H" & norec + 12) = ws_core.Range("AR2:AR" & norec + 1).Value
        .Range("I13:I" & norec + 12) = ws_core.Range("AU2:AU" & norec + 1).Value
        .Range("J13:J" & norec + 12) = ws_core.Range("X2:X" & norec + 1).Value
        .Range("K13:K" & norec + 12) = ws_core.Range("AA2:AA" & norec + 1).Value
        .Range("L13:L" & norec + 12) = ws_core.Range("AC2:AC" & norec + 1).Value
        .Range("M13:M" & norec + 12) = ws_core.Range("BQ2:BQ" & norec + 1).Value
        .Range("N13:N" & norec + 12) = ws_core.Range("BX2:BX" & norec + 1).Value
        .Range("O13:O" & norec + 12) = ws_core.Range("CE2:CE" & norec + 1).Value
        .Range("P13:P" & norec + 12) = ws_core.Range("CL2:CL" & norec + 1).Value
        .Range("Q13:Q" & norec + 12) = ws_core.Range("AX2:AX" & norec + 1).Value
        
        For i = 13 To 12 + norec
            
            fac5 = WorksheetFunction.VLookup(.Range("A" & i), ws_core.Range("A2:I" & norec + 1), 8, False) & WorksheetFunction.VLookup(.Range("A" & i), ws_core.Range("A2:I" & norec + 1), 9, False)
            .Range("D" & i) = WorksheetFunction.VLookup(fac5, fac_rng, 7, False)
            .Range("R" & i) = WorksheetFunction.VLookup(.Range("A" & i), ws_core.Range("A2:I" & norec + 1), 5, False)
            If .Range("Q" & i) = "FALSE" Then .Range("Q" & i) = ""
        Next i
        
        CList(1) = "DT"
        CList(2) = "DR"
        CList(3) = "FT"
        CList(4) = "FR"
        CList(5) = "CT"
        CList(6) = "CR"
        Application.AddCustomList ListArray:=CList
        .Range("A13:R" & norec + 12).Sort Key1:=Range("R13"), Order1:=xlAscending, key2:=Range("F13"), order2:=xlAscending, key3:=Range("D13"), order3:=xlAscending, Header:=xlGuess, _
            OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        Application.DeleteCustomList Application.CustomListCount
    
    End With
        
End Sub