Error Handling if Excel Crashes

[BrianG86]

Hi All,

I have a form thats coded so that users on the network can submit entries on to a master workbook.

The code checks if the master workbook is opened, if it is, a message will pop up asking them to try again. If not then it opens the workbook and theres a few simple copy and pastes, before it closes and saves the master workbook.

There is an "unlikely" event thats now happened twice in one day, where the users excel has crashed when running the code at the time when the master workbook is opened and it has left them in it, which then prevents anyone else from running the code.

I am looking for some code that will just close, give a user message, and not save the master workbook if execl crashes.

 

[BrianG86]

Just for completeness, my code is below:

Sub IssuesLogForm()
Dim wb As Workbook, twb As Workbook
Dim ws As Worksheet, tws As Worksheet

'''''''''''''''''''''''''
If Sheets(2).Cells(1, 4) = "Blanks" Then
MsgBox "Please ensure all fields are completed"
Exit Sub
Else
If Sheets(2).Cells(1, 3).Value = "No" Then
MsgBox "Please ensure that the Order Number is 8 digits long"
Exit Sub
Else
'''''''''''''''''''''''''
                    Application.ScreenUpdating = False
 

Select Case IsFileFree("S:\John Lewis\Common\Complaints\Insight Data.xlsm")
Case 0
MsgBox "Your entry was not submitted as the network was busy, please try again."
Exit Sub
Case 1
MsgBox "file not found"
Exit Sub
Case -1
Set wb = Workbooks.Open("S:\John Lewis\Common\Complaints\Insight Data.xlsm", UpdateLinks:=3, WriteResPassword:="Insight1", IgnoreReadonlyRecommended:=True)
Set ws = wb.Sheets(1)
Set twb = ThisWorkbook
Set tws = twb.Sheets(1)
tws.Cells(1, 5).Copy
    
ws.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
tws.Cells(4, 5).Copy
ws.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
tws.Cells(6, 5).Copy
ws.Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
tws.Cells(8, 5).Copy
ws.Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
tws.Cells(10, 5).Copy
ws.Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
tws.Cells(12, 5).Copy
ws.Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
tws.Cells(14, 5).Copy
ws.Range("F" & Rows.Count).End(xlUp).Offset(0, 1).PasteSpecial xlPasteValues
tws.Cells(16, 5).Copy
ws.Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
tws.Cells(18, 5).Copy
ws.Range("H" & Rows.Count).End(xlUp).Offset(0, 1).PasteSpecial xlPasteValues
tws.Cells(20, 5).Copy
ws.Range("J" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        wb.Close True
        
End Select
End If
End If
                    Application.ScreenUpdating = True
                    
MsgBox "Your entry has been submitted"

End Sub

Sub ClearAll()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
ws.Cells(4, 5).ClearContents
ws.Cells(6, 5).ClearContents
ws.Cells(8, 5).ClearContents
ws.Cells(10, 5).ClearContents
ws.Cells(12, 5).ClearContents
ws.Cells(14, 5).ClearContents
ws.Cells(16, 5).ClearContents
ws.Cells(18, 5).ClearContents
ws.Cells(20, 5).ClearContents
MsgBox "Data has been cleared"
End Sub
 
Function IsFileFree(sFileName As String) As Integer
Dim wb As Workbook
Dim iReturn As Integer
Dim bScreen As Boolean
bScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
Set wb = Workbooks.Open("S:\John Lewis\Common\Complaints\Insight Data.xlsm", UpdateLinks:=3, WriteResPassword:="Insight1", IgnoreReadonlyRecommended:=True)
If wb Is Nothing Then
iReturn = 1
Else
If wb.ReadOnly Then
iReturn = 0
Else
iReturn = -1
End If
wb.Close False
End If
Application.ScreenUpdating = bScreen
IsFileFree = iReturn
End Function

 

[BrianG86]

Bump