Ark68
Well-known Member
- Joined
- Mar 23, 2004
- Messages
- 4,564
- Office Version
- 365
- 2016
- Platform
- 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.
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