检查文件是否打开以防止错误 - Pt。 2个

Question

关于这个 post：我已经更新了代码，但现在我收到了：

运行-时间错误9：下标超出范围

调试器突出显示这行代码（下面是完整代码，以及 IsWBOpen 的函数）：

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

我唯一能想到的是 .Sheets("Swivel") 是罪魁祸首，但我不确定。

这是我想要完成的：

如果用户单击“否”，则子程序以 MsgBox 消息结束，说明此过程将终止。如果用户单击“是”并且工作簿未打开，则用户会收到与单击“否” 和相同的消息，子程序结束。如果用户单击“是”并且工作簿已打开，子程序将继续。

函数如下：

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

这里是主子：

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 和 user1016274 对到目前为止的代码非常有帮助。感谢有关此错误的所有帮助。

Answer 1

改变这个：

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

至：

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

检查文件是否打开以防止错误 - Pt。 2个

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

excel

vba

excel-2007