Search code examples
excelexcel-2007vba

Checking if File is open to prevent error


I have looked and could not find an answer to this specifically. The below code prompts the user as to whether or not a specific file is open. If the user clicks no, the sub ends. If they click yes, the sub continues. I have tested this with the file open and all works great. But then I forgot to open the file and clicked yes when prompted and received the following error:

Run-time error '9':

Subscript out of range

For this line in the code:

With Workbooks("Swivel - Master - December 2015.xlsm").Sheets("Swivel")

I understand why I am getting the error, but how do I check if the "yes" answer from the user is true to prevent this error?

Here is the full code:

Sub Extract_Sort_1512_December()
'
'
    Dim ANS As String
    ANS = MsgBox("Is the December 2015 Swivel Master File checked out of SharePoint and currently open on this desktop?", vbYesNo + vbQuestion + vbDefaultButton1, "Master File Open")
    If ANS = vbNo Then
        MsgBox "This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
        Exit Sub
    End If

Application.ScreenUpdating = False

    ' This line renames the worksheet to "Extract"
    ActiveSheet.Name = "Extract"

    ' This line autofits the columns C, D, O, and P
    Range("C:C,D:D,O:O,P:P").Columns.AutoFit

    ' This unhides any hidden rows
    Cells.EntireRow.Hidden = False

Dim LR As Long

    For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("B" & LR).Value <> "12" Then
            Rows(LR).EntireRow.Delete
        End If
    Next LR

With ActiveWorkbook.Worksheets("Extract").Sort
    With .SortFields
        .Clear
        .Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("D2:D2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("O2:O2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("J2:J2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("K2:K2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("L2:L2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    .SetRange Range("A2:Z2000")
    .Apply
End With
Cells.WrapText = False
Sheets("Extract").Range("A2").Select

    Dim LastRow As Integer, i As Integer, erow As Integer

    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LastRow
        If Cells(i, 2) = "12" Then

            ' As opposed to selecting the cells, this will copy them directly
            Range(Cells(i, 1), Cells(i, 26)).Copy

            ' As opposed to "Activating" the workbook, and selecting the sheet, this will paste the cells directly
            With Workbooks("Swivel - Master - December 2015.xlsm").Sheets("Swivel")
                erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                .Cells(erow, 1).PasteSpecial xlPasteAll
            End With
            Application.CutCopyMode = False
        End If
    Next i

Application.ScreenUpdating = True
End Sub

I have worked through many errors in this code over the last two days and am a little fried, so any help is appreciated.

Here is my updated IF statement to check the status of the workbook required to proceed:

Dim ANS As String

    ANS = MsgBox("Is the November 2015 Swivel Master File checked out of SharePoint and currently open on this desktop?", vbYesNo + vbQuestion + vbDefaultButton1, "Master File Open")
    If ANS = vbNo Then
        MsgBox "This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
        Exit Sub
        ElseIf IsWBOpen("Swivel - Master - November 2015") Then
    End If

Solution

  • Use this function to check if the desired workbook is open:

    Function IsWBOpen(WorkbookName As String) As Boolean
    ' check if WorkbookName is already opened; WorkbookName is without path or extension!
    ' comparison is case insensitive
    ' 2015-12-30
    
        Dim wb As Variant
        Dim name As String, searchfor As String
        Dim pos as Integer
    
        searchfor = LCase(WorkbookName)
        For Each wb In Workbooks
            pos = InStrRev(wb.name, ".")
            If pos = 0 Then                           ' new wb, no extension
                name = LCase(wb.name)
            Else
                name = LCase(Left(wb.name, pos - 1))  ' strip extension
            End If
            If name = searchfor Then
                IsWBOpen = True
                Exit Function
            End If
        Next wb
        IsWBOpen = False
    End Function
    

    It looks through the list of (opened) workbooks and compares the name to it's argument. The extension is stripped off, there is no path prepended and the comparison is case-insensitive.
    Usage:
    If IsWbOpen("Swivel - Master - December 2015") then '... proceed Else Exit Sub End If