errorhandeling does not work on SaveAs if file already open-CodePudding

I have a small code that needs to run when closing the excel file.

the file needs to make a copy that is read only so that the original can be amended at the same time.

this part works if the readonly copy is closed but when the copy is open I get a runtime error: cannot save if file is open on another device. So far my attempts to handle the error have not worked. Does anyone know if and how I can "ignore" this error?

Sub createcopy()

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Dim ws As Worksheet
For Each ws In Worksheets
    ws.Protect Password:="", AllowFiltering:=True, AllowSorting:=True
Next ws

On Error GoTo 2
ThisWorkbook.SaveAs Filename:="file123-readonly", FileFormat:=xlWorkbookDefault, Password:=""
On Error GoTo 2


Application.ScreenUpdating = True

Application.DisplayAlerts = True

2 Application.Quit

Exit Sub
End Sub

CodePudding user response：

You will never be able to save overwriting an open workbook. So, you must preliminarily check if a workbook with the same name is open, if so, close it and save it after. Please, try the next way:

Sub createcopy()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim ws As Worksheet, wbName As String
For Each ws In Worksheets
    ws.Protect password:="", AllowFiltering:=True, AllowSorting:=True
Next ws

wbName = "file123-readonly.xlsx" 'full workbook name
                                 'If without extension, it must be added (inside the string or in code)
If isWbOpen(wbName) Then
    Workbooks(Split(wbName, "\")(UBound(Split(wbName, "\")))).Close , False
End If

ThisWorkbook.saveas fileName:=wbName, FileFormat:=xlWorkbookDefault, password:=""
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

CodePudding user response：

With the help of FaneDuru and something I found somewhere else this is what I use now:

Private Sub Workbook_BeforeClose(Cancel As Boolean)


If ThisWorkbook.Saved = False Then

Dim answer As Integer
 
answer = MsgBox("Do you want to save? ", vbQuestion   vbYesNo   vbDefaultButton2, "Save file?")

If answer = vbYes Then
  ThisWorkbook.Save
  GoTo 4
Else
GoTo 3
End If

3 ThisWorkbook.Saved = True
Application.Quit

ElseIf ThisWorkbook.Saved = True Then


4 Application.DisplayAlerts = False

Application.ScreenUpdating = False

ThisWorkbook.SaveAs FileName:="file123- backup", FileFormat:=xlWorkbookDefault, Password:="****"

Dim ws As Worksheet
For Each ws In Worksheets
    ws.Protect Password:="", AllowFiltering:=True, AllowSorting:=True
Next ws



Dim FilePath As String
FilePath = IsWBOpen("file123- readonly.xlsx")
If FilePath = True Then
2 Application.Quit
Exit Sub
Else
On Error GoTo 2

ThisWorkbook.SaveAs FileName:="file123-readonly.xlsx", FileFormat:=xlWorkbookDefault, Password:=""
On Error GoTo 2

 End If

Application.ScreenUpdating = True

Application.DisplayAlerts = True

Application.Quit

End If


Exit Sub
End Sub

Function IsWBOpen(FileName As String)
'declare variables
Dim FileNo As Long
Dim ErrorNo As Long
On Error Resume Next
FileNo = FreeFile()
On Error Resume Next
Open FileName For Input Lock Read As #FileNo
Close FileNo
ErrorNo = Err
On Error GoTo 0
Select Case ErrorNo
Case 0
IsWBOpen = False
Case 70
IsWBOpen = True
Case Else
Error ErrorNo
End Select
End Function