Excel Crashes After Custom Sort Code

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
3,860
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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.

Rich (BB code):
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
 

Some videos you may like

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

Watch MrExcel Video

Forum statistics

Threads
1,127,554
Messages
5,625,474
Members
416,109
Latest member
TripleA00123

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top