Question

我在Microsoft Excel 2010中编写了一些附加到ActiveX命令按钮的代码。该代码用于查找电子表格中的最后一行，将第一列添加到集合中并删除重复项，为内容列表创建新的电子表格，并列出集合中的每个唯一值，并创建要与之一起使用的命名范围。另一个电子表格作为下拉列表。虽然截至昨天我现在收到标题中的上述错误。以下是代码：

Option Explicit
Private Sub btnCloseShipsList_Click()
'===============================================================================================
'Description: Builds the List Data Validation drop-down menus and hides all sheets except [SITE, _
    SYSTEM or INVESTIGATION REQ'D]
'Originally written by: Troy Pilewski
'Date: 2016-01-20
'===============================================================================================
Dim i As Integer
Dim xWs As Worksheet, xWb As Workbook, rng As Range, ws As Worksheet, wsHull As Worksheet
Dim lngLastRow As Long, lngShipRow, lngLastHull As Long
Dim xTitle As String, strShips() As String
Dim vntShips As Variant, Ships As Collection


'Turn off application events to speed up code
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

'Assigns a string to the title variable
xTitle = "TABLE OF CONTENTS"

'Unhides TABLE OF CONTENTS sheet and deletes it to recreate a new one
Application.Sheets(xTitle).Visible = xlSheetVisible
Application.Sheets(xTitle).Delete
Application.Sheets.Add Before:=Worksheets(1)

'Sets the Datasheet as the active worksheet
Set xWs = Application.ActiveSheet
Set wsHull = Application.Sheets("HULL_TYPES")

xWs.Name = xTitle

'Creates a title row
With xWs.Cells(1, 1)
    .Value = "Sheet Names"
    .Font.Bold = True
End With
'Creates a generic placeholder
With xWs.Cells(2, 1)
    .Value = "SHIPNAME (CLASS)"
End With

'Determine the last row with values
Set xWs = Application.Sheets("SHIPS")

'Call DeleteEntireRow

'Call SystemNamePropigation

lngLastRow = xWs.Range("A:A").Find( _
    What:="*", _
    After:=xWs.Range("A1"), _
    Lookat:=xlByRows, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious _
).Row
lngLastHull = wsHull.Range("A:A").Find( _
    What:="*", _
    After:=wsHull.Range("A1"), _
    Lookat:=xlByRows, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious _
).Row

'Creates and adds each Ship to a collection
If lngLastRow > 2 Then
    vntShips = xWs.Range("A3:A" & lngLastRow).Value
    Set Ships = New Collection

    'Loop through the array of all Ship values (duplicates will be in this list)
    For lngShipRow = LBound(vntShips, 1) To UBound(vntShips, 1)

        'Check the first unique value of a Ship
        If KEYISINCOLLECTION(Ships, CStr(vntShips(lngShipRow, 1))) = False Then

            'Add the first unique Ship to the collection
            Ships.Add CStr(vntShips(lngShipRow, 1)), CStr(vntShips(lngShipRow, 1))
        End If
    Next lngShipRow

    'Converts collection to a string
    With Ships
        ReDim strShips(.Count) As String
    '    MsgBox UBound(strShips)
        For i = 1 To .Count
            strShips(i) = .Item(i)
        Next i
    End With
End If

For Each ShipRecord In xWs.Range("F3:F" & lngLastRow)
    If ShipRecord = vbNullString And Range(ShipRecord.Address).Offset(0, -1) = vbNullString Then
        'MsgBox Range(ShipRecord.Address).Offset(0, -2) & " has No Scan Data"
    ElseIf ShipRecord = vbNullString And Range(ShipRecord.Address).Offset(0, -1) > Now() - 1 Then
        Range(ShipRecord.Address) = "0"
    End If
Next

'Loops through worksheet and lists them in a column and adds a hyperlink to the sheet
Set xWs = Application.Sheets("TABLE OF CONTENTS")

If lngLastRow > 2 Then
    For i = LBound(strShips) + 1 To UBound(strShips)
        With wsHull
            ReDim HullTypes(lngLastHull)
            HullTypes = .Range("A3:B" & lngLastHull).Value
        End With
        With Application.WorksheetFunction
            Dim HullNumber As String
            HullNumber = .Index(HullTypes, .Match(strShips(i), wsHull.Range("A3:A" & lngLastHull)), 2)
        End With
        With xWs.Cells(i + 2, 1)
            .Value = strShips(i) & Chr(32) & "(" & HullNumber & ")"
    '        .Hyperlinks.Add anchor:=Cells(i + 1, 1), Address:="", _
    '        SubAddress:="'" & Worksheets(i).name & "'!$A$1"
        End With
    '    MsgBox Cells(i + 2, 1)
    Next
    'For i = 2 To Worksheets.count - 3
    '    With Cells(i + 1, 1)
    '        .value = Worksheets(i + 3).name
    '        .Hyperlinks.Add anchor:=Cells(i + 1, 1), Address:="", _
    '        SubAddress:="'" & Worksheets(i).name & "'!$A$1"
    '    End With
    'Next
End If

'Sets the Datasheet as the active worksheet
Set xWb = ActiveWorkbook

'Determine the last row with values
Set xWs = Application.Sheets("TABLE OF CONTENTS")
lngLastRow = xWs.Range("A:A").Find( _
    What:="*", _
    After:=xWs.Range("A1"), _
    Lookat:=xlByRows, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious _
).Row

'Sets the range for the Named Object
Set rng = xWs.Range("$A$1:$A$" & lngLastRow - 1).Offset(1, 0)

'MsgBox CStr(rng)

'Creates a Named Object Range and assignes its range
xWb.Names.Add Name:="SheetList", RefersTo:=rng

'Changes the column width to autofit to the contents of the column
xWs.Cells(1, 1).EntireColumn.AutoFit

'loops through the all worksheets and hides them unless they are SITE, SYSTEM or INVESTIGATION REQ'D
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "TABLE OF CONTENTS" Then
        ws.Visible = xlSheetVeryHidden
    ElseIf ws.Name = "HULL_TYPES" Then
        ws.Visible = xlSheetVeryHidden
    ElseIf ws.Name = "SYSTEM_LIST" Then
        ws.Visible = xlSheetVeryHidden
    ElseIf ws.Name = "SITE" Then
        ws.Visible = xlSheetVisible
    ElseIf ws.Name = "SYSTEM" Then
        ws.Visible = xlSheetVisible
    ElseIf ws.Name = "INVESTIGATION REQ'D" Then
        ws.Visible = xlSheetVisible
    Else
        ws.Visible = xlSheetHidden
    End If
Next ws

'Application.Sheets(1).Visible = False
End Sub

Public Function KEYISINCOLLECTION(CollTemp As Collection, KeyToCheck As String) As Boolean
'===============================================================================================
'Description: Validates the selection is not already in the collection
'Originally written by: Zack Barresse
'Date: 2014-09-15
'===============================================================================================

    On Error Resume Next
    KEYISINCOLLECTION = CBool(Not IsEmpty(CollTemp(KeyToCheck)))
    On Error GoTo 0
End Function

Answer 1

您可能通过设置＆＃34;中断所有错误＆＃34;。

来禁用错误处理程序

在VBA窗口中，转到Tools - ＆gt; Options - ＆gt; General - ＆gt; Error Trapping并选择Break on Unhandled Errors。

Answer 2

您的KEYISINCOLLECTION()功能适合我

你可能想尝试这个代码的小变化

Public Function KEYISINCOLLECTION(CollTemp As Collection, KeyToCheck As String) As Boolean
    Dim x As Variant
    On Error Resume Next
    x = CollTemp(KeyToCheck)
    On Error GoTo 0
    KEYISINCOLLECTION = Not IsEmpty(x)
End Function

Answer 3

对我而言，它的工作原理可能只有两个：
1。有一件事我注意到，如果你重新运行代码而你永远不会set Ships = Nothing第一次完成它可能会导致奇怪的行为。
2。只要这个条件得到满足就不应该是一个问题If KEYISINCOLLECTION(Ships, CStr(vntShips(lngShipRow, 1))) = False Then我看到这是一个范围，可能是在那个范围内有一个公式错误？
OT：我看到了一些机会，如果可以的话，为什么要将range.value设置为集合系列而不是范围，然后根据需要在代码中设置.value？ 2.为什么不使用字典而不是收藏？那个功能＆＃34; KEYISINCOLLECTION＆＃34;已被定义为＆＃34; Exists＆＃34;在字典中。不要发明轮子;）

运行时错误'5'：无效的过程调用或参数

3 个答案: