Iron Man
Iron Man

Reputation: 849

Checking if a file is open to prevent error - Pt. 2

In reference to this post: Checking if File is open to prevent error I have updated the code, but now I am receiving:

Run-time error 9: Subscript out of range

and the debugger highlights this line of the code (Full code is below, along with the Function for IsWBOpen):

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

The only thing I can think of is that the .Sheets("Swivel") is the culprit, but I am not sure of this.

Here is what I am trying to accomplish:

If the user clicks No, then the sub ends with the MsgBox message stating this procedure will terminate. If the user clicks yes and the workbook is not open, the user gets the same message as if they clicked on No and the sub ends. If the user clicks Yes and the workbook is open, the sub continues.

here is the Function:

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

Here is the main sub:

Sub Extract_Sort_1511_November()
'
'
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
    Else
        If ANS = vbYes Then
            If IsWBOpen("Swivel - Master - November 2015.xlsm") Then
            End If
            Else
                MsgBox "This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
                Exit Sub
        End If
    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 <> "11" 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) = "11" 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 - November 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

findwindow and user1016274 have been very helpful in getting the code this far. All assistance on this error is appreciated.

Upvotes: 1

Views: 141

Answers (1)

Fadi
Fadi

Reputation: 3322

change this:

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
    Else
        If ANS = vbYes Then
            If IsWBOpen("Swivel - Master - November 2015.xlsm") Then
            End If
            Else
                MsgBox "This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
                Exit Sub
        End If
    End If

to :

Dim ANS As Long

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 Or IsWBOpen("Swivel - Master - November 2015") = False Then
    MsgBox "This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
    Exit Sub                   
End If

Upvotes: 1

Related Questions