Why My VBA Project Crashes When Trying To Save

[Ark68]

I realize this is likely a tough question to answer given the fact that I can't provide all my code (it's a large worksheet bvased "application") or the file to play with due to it's use of network drives and a variety of external data ssources. So I come looking for just a general answer. My sincere apologies in advance.

After my code runs, everything seems in order until I save the workbook. When I save the workbook, Excel shuts down. No error messages, it just shuts down then restarts with that file reopened (but not a recovered version ... a version without an corrections made prior to it's attempt to be saved).

Are there any diagnostic tools or tricks to determine what might be causing this? Are there any common circumstances which usually result in this kind of behaviour, and how would I check to see if these are contributors?

 

[Ark68]

I must add, that it not only crashes when I try to save, but after a moment of being idle after the code runs, it crashes.

I seem to possibly have isolated the cuase to this procedure. If I run my application and bypass this procedure, when the code ends, I don't have the crashes. As soon as I add this procedure back into the run, the application crashes at the end. It's not very efficient code, I'm still learning.

Sub pda_assign1()
    'Checked 21-03-04

    Dim rng_dss As Range 'raw data daily staff schedule ws_t_hold A2:G?
    Dim drow As Double 'destination row in thold for raw staff data
    Dim lr_pda As Double 'pda last row of section
    Dim L1 As Double 'loop counter 1
    
    With ws_thold
        'Stop
        'master static staff list
        .Range("A2:AZ200").ClearContents 'clear t_hold except for header
        'delete named range nr_dss (daily staff schedule) if it exists
        On Error Resume Next
        ThisWorkbook.Names("nr_dss").Delete
        On Error GoTo 0
        'Create list of all employees working for eligibility
        drow = 2 'start of data in t_hold
        For L1 = 10 To 37 'extract data from schedule in ws_master (count through rows)
            If ws_master.Cells(L1, 22) <> "" Then
                .Cells(drow, 1) = ws_master.Cells(L1, 19) 'shift (s)
                .Cells(drow, 2) = ws_master.Cells(L1, 23) 'name (w)
                .Cells(drow, 3) = ws_master.Cells(L1, 22) 'crew (v)
                .Cells(drow, 4) = ws_master.Cells(L1, 20) 'time on (d)
                .Cells(drow, 5) = ws_master.Cells(L1, 21) 'time off (e)
                .Cells(drow, 6) = Left(.Cells(drow, 1), 3) 'time off (e)
                .Cells(drow, 7) = .Cells(drow, 6) & "  " & .Cells(drow, 2)
                drow = drow + 1 'advance data holding row
            End If
        Next L1
        'assign named range of daily staff roster (dsr)
        'this named range will provide the list for assignment selection cells in master
        Set rng_dss = .Range("A2:A" & drow)
        ThisWorkbook.Names.Add Name:="nr_dss", RefersTo:=rng_dss
    End With
    
    With ws_master
        'find last row of PDA (default is 37 but will expand with records exceeding 21
        lr_pda = Application.WorksheetFunction.Match("Facility Maintenance Activities", .Columns(1), 0)
        'how many records in PDA (equal to the number of records in core_data)
        nrec = Application.WorksheetFunction.CountA(.Range("C12:C" & lr_pda))
        'if no records to assign, then proceed with dispatching services
        If nrec = 0 Then 'no records to assign
            MsgBox "No rentals to assign."
            'proceed to services assignments
            MsgBox "Although there are no program records to process, applicable routine services must be assisgned." & _
                "This code is currently unwritten.", , "End of routine"
            Stop
        End If

        Application.Wait (Now + TimeValue("00:00:01"))

        'BEGIN DEFAULT ASSIGNMENTS
        'acquire individual booking static elements
Stop
        For srow = 13 To 12 + nrec  'source(ws_master) row
            bkg_type = .Cells(srow, 2) 'booking type (DR,FR, CR etc)
            pnum = .Cells(srow, 3)  'permit number
            fac2 = .Cells(srow, 4)  'LABEL (col6) in core_data
            bkg_date = CDbl(.Range("M1"))
            bkg_st = .Cells(srow, 6)    'start time
            bkg_et = .Cells(srow, 7)    'end time
            If bkg_et < bkg_st Then 'booking carries over into the next day
                bkg_det = bkg_date + 1 + bkg_et 'booking ends 1 day after booking date plus the time
            Else
                bkg_det = bkg_date + bkg_et
            End If
            bkg_dst = bkg_date + bkg_st
            
            'Stop 'to assess assignments based on activity code
            
            Application.ScreenUpdating = False
            
            If bkg_type Like "F*" Then
                pt = "F" 'program type
               ' Stop
                'no services
                With ws_master
                    unlocked '.Unprotect
                    mbevents = False
                    'no groom
                    With .Cells(srow, 8)
                        .Interior.Color = RGB(166, 166, 166)
                        .Value = ""
                    End With
                    'no tournament relining (column 13-16)
                    With .Range("M" & srow & ":Q" & srow)
                        .Interior.Color = clr_grey
                        .Value = ""
                    End With
                    locked '.Protect
                    mbevents = True
                End With
                'Stop
                signatures '{assignments}*
                prg_prep '{assignments}*
                prg_lights '{assignments}*
                prg_details '(assignments)
                
            ElseIf bkg_type Like "D*" Then
                isdt = 0
                pt = "D"
                If .Cells(srow, 2) = "DT" Then isdt = 1
                'Stop
                signatures '{assignments}*
                'Stop
                prg_prep '{assignments}*
                'Stop
                prg_groom '{assignments}* 'redo based on svc_type determined in prg_prep
                'Stop
                prg_lights '{assignments}*
                'Stop
                prg_close '{assignments}*
                prg_details

                If isdt = 1 Then
                    prg_treline
                Else
                    unlocked '.Unprotect
                    mbevents = False
                    With .Range("M" & srow & ":P" & srow)
                        .Interior.Color = clr_grey
                        .Value = ""
                    End With
                    mbevents = True
                    locked '.Protect
                End If
                
            ElseIf bkg_type Like "C*" Then
                pt = "C"
                'no services
                With ws_master
                    unlocked '.Unprotect
                    mbevents = False
                    'no tournament relining (column 13-16)
                    With .Range("K" & srow & ":P" & srow)
                        .Interior.Color = clr_grey
                        .Value = ""
                    End With
                    locked '.Protect
                    mbevents = True
                End With
                signatures '{assignments}
                prg_groom  '{assignments} 'default NR, create validation list
                prg_prep '{assignments}
                prg_lights '{assignments}
                prg_close 'close '{assignments}
                prg_details
                
            ElseIf bkg_type Like "G*" Then
                pt = "G"
                'no services
                With ws_master
                    unlocked '.Unprotect
                    mbevents = False
                    'no groom
                    With .Cells(srow, 8)
                        .Interior.Color = clr_grey
                        .Value = ""
                    End With
                    'no tournament relining
                    With .Range("K" & srow & ":P" & srow)
                        .Interior.Color = clr_grey
                        .Value = ""
                    End With
                    locked '.Protect
                    mbevents = True
                End With
                signatures  '{assignments}
                prg_prep '{assignments}
                prg_close 'close '{assignments}
                prg_details
                
            ElseIf bkg_type Like "T*" Then
                pt = "T"
                'no services
                With ws_master
                    unlocked '.Unprotect
                    mbevents = False
                    'no groom / prepare
                    With .Range("H" & srow & ":I" & srow)
                        .Interior.Color = clr_grey
                        .Value = ""
                    End With
                    'no tournament relines
                    With .Range("K" & srow & ":Q" & srow)
                        .Interior.Color = clr_grey
                        .Value = ""
                    End With
                    locked '.Protect
                    mbevents = True
                End With
                signatures '{assignments}
                prg_details
            
            ElseIf bkg_type Like "S*" Then
                pt = "S"
                'no services
                With ws_master
                    unlocked '.Unprotect
                    mbevents = False
                    'no groom
                    With .Range("H" & srow)
                        .Interior.Color = clr_grey
                        .Value = ""
                    End With
                    'no tournament relines
                    With .Range("K" & srow & ":P" & srow)
                        .Interior.Color = clr_grey
                        .Value = ""
                    End With
                    locked '.protect
                End With
                signatures '{assignments}
                prg_prep '{assignments}
                prg_close 'close '{assignments}
                prg_details
            Else
                Stop
                Debug.Print "Booking Type: " & bkg_type
                If Not bkg_type Like "Reline*" And Not bkg_type Like "Change*" Then
                    MsgBox "Error: pda_assign1" & Chr(13) & "An unrecognized activity code (D*, F*, etc) has been encountered.", vbCritical, "Unable to continue..."
                    Stop
                End If
            End If
            Application.ScreenUpdating = True
        Next srow 'process next booking in ws_master
        
        'this sorts the pda range to include any newly added rows (ie tournament) after all original bookings have been assigned
        .Activate
        .Unprotect
        Application.EnableEvents = False
        
        wisADD = Application.WorksheetFunction.Match("ADD", .Columns(1), 0)
        Set PdaSortRng = ws_master.Range("A13:R" & wisADD)
        PdaSortRng.Sort key1:=Range("R13"), order1:=xlAscending, Header:=xlNo
        
        wisADD = Application.WorksheetFunction.Match("ADD", .Columns(1), 0)
        For i = 13 To wisADD - 1
            Debug.Print i
            If Application.WorksheetFunction.IsNumber(.Cells(i, 2)) = True Then
                srcRID = Left(.Cells(i, 1), 8) & "-" & .Cells(i, 2)
                tsvcsRow = Application.WorksheetFunction.Match(srcRID, ws_TrnSrvs.Columns(13), 0)
                ws_TrnSrvs.Cells(tsvcsRow, 14) = i
                
                'dispatch assignment for service line
                If ws_TrnSrvs.Cells(tsvcsRow, 16) = "RLN" Then
                    d1 = "RELINE"
                Else
                    d1 = "CHANGE"
                End If
                dmsg = d1 & " " & Format(ws_TrnSrvs.Cells(tsvcsRow, 17), "h:mmA/P") & "-" & Format(ws_TrnSrvs.Cells(tsvcsRow, 18), "h:mmA/P")
                ws_TrnSrvs.Cells(tsvcsRow, 24) = dmsg
                
                Set PdaDestCell = .Cells(i, 2)
                With PdaDestCell
                    .Font.Size = 6
                    .Font.Color = vbBlack
                    .Font.Bold = True
                    .Value = dmsg
                    .HorizontalAlignment = xlCenter
                End With
                ws_master.Rows(i).AutoFit
            End If
        Next i
        Application.EnableEvents = False
        .Protect
    End With
    
End Sub

 

[ExcelRobot]

Hi, does your code have any event triggered code that runs on the OnSave event? If you did, it would be in the ThisWorkbook module. Also, do you recall when this started happening? Did it just start happening out of the blue or related to changes you were making to this particular piece of code?

 

[Ark68]

Hi ExcelRobot - thanks for your reply.
I don't have an OnSave event, so it's not that.

I did go back to that last chunk of code I added before I suspect things started going sideways. I took that block of code and commented it out so it didn't execute and I wasn't able to recreate the problem.

I took that block of code and placed it in a different point of execution ... in the module after from which pda_assign1 (posted in post #2) is called

.

Here is that block of code (originally in the module provided in post #2). I know it may or may not solve the problem as it may not necessarily be the code, but how the code interacts with the worksheet etc. But, if I'm lucky, someone will see an obvious problem. It caused problems in the original module, and the alternate module. Without the code, no issues.

wisADD = Application.WorksheetFunction.Match("ADD", .Columns(1), 0)
        Set PdaSortRng = ws_master.Range("A13:R" & wisADD)
        PdaSortRng.Sort key1:=Range("R13"), order1:=xlAscending, Header:=xlNo
        
        wisADD = Application.WorksheetFunction.Match("ADD", .Columns(1), 0)
        For i = 13 To wisADD - 1
            Debug.Print i
            If Application.WorksheetFunction.IsNumber(.Cells(i, 2)) = True Then
                srcRID = Left(.Cells(i, 1), 8) & "-" & .Cells(i, 2)
                tsvcsRow = Application.WorksheetFunction.Match(srcRID, ws_TrnSrvs.Columns(13), 0)
                ws_TrnSrvs.Cells(tsvcsRow, 14) = i
                
                'dispatch assignment for service line
                If ws_TrnSrvs.Cells(tsvcsRow, 16) = "RLN" Then
                    d1 = "RELINE"
                Else
                    d1 = "CHANGE"
                End If
                dmsg = d1 & " " & Format(ws_TrnSrvs.Cells(tsvcsRow, 17), "h:mmA/P") & "-" & Format(ws_TrnSrvs.Cells(tsvcsRow, 18), "h:mmA/P")
                ws_TrnSrvs.Cells(tsvcsRow, 24) = dmsg
                
                Set PdaDestCell = .Cells(i, 2)
                With PdaDestCell
                    .Font.Size = 6
                    .Font.Color = vbBlack
                    .Font.Bold = True
                    .Value = dmsg
                    .HorizontalAlignment = xlCenter
                End With
                ws_master.Rows(i).AutoFit
            End If
        Next i

This code is applied to worksheet alias ws_master. This sheet does have double click and change events associated to select ranges of cells incase that helps provide a clue.

 

[Ark68]

After each crash, a 0 KB with an 8 character random alpha-numeric file name is created in the folder holding the workbook.

 

[RoryA]

Why does pdaassign1 disable events at the end? They are already disabled, so I'm guessing you meant to re-enable them?

 

[Ark68]

Hi Rory, I was really encouraged you had the solution! Unfortunately, reinstating that block of code in procedure "pda_assign1" and changing the parameter of enableevents to true (which you're correct it should have been) did not solve the problem. I even removed it ,and all enableevents references for that matter, in that module and still encountered the problem.

This exists on two separate computers ... one running Office 365 and the other Office Plus 2016

 

[Ark68]

By process of elimination ... I've found that this line of code in red seems to be causing issues.

        wisADD = Application.WorksheetFunction.Match("ADD", .Columns(1), 0)
        Set PdaSortRng = ws_master.Range("A13:R" & wisADD)
        PdaSortRng.Sort key1:=Range("R13"), order1:=xlAscending, Header:=xlNo

Although it does what it's supposed to, it is contributing to, or is the cause of, the issue. With this line alone eliminated, the problem is avoided.

 

[RoryA]

You could try amending it to:

PdaSortRng.Sort key1:=ws_master.Range("R13"), order1:=xlAscending, Header:=xlNo

 

[NoSparks]

the .Sort makes this somewhat similar to a post by starl a week or so back