Reputation: 849
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
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