excel 为什么代码给出400错误，但在调试模式下运行

我有一个问题，下面的代码在调试模式下运行良好，但在正常激活时抛出400错误。它一直卡在代码的Sub Assignee_List部分，特别是Sheets("Input List").Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants).Select行。我不知道为什么。
很抱歉发布了一大块代码，但我不知道是什么部分导致了这个问题。就我在调试期间从我的局部变量窗口所知，代码没有从其他子对象中提取任何值到Assignee_List子对象中。
对于上下文，Assignee_List sub查看分配给任务列表的职员的姓名，并将其筛选为唯一值列表（每个姓名出现一次），然后将该列表转换为命名范围，以支持工作簿中其他位置的数据验证列表。

Sub Dashboard_Update()
        
    'Main Sub which runs all other subs from the 'Update' dashboard button
        
    Proceed1 = MsgBox("Have you Captured a Burndown Snapshot? (If Required)", vbYesNo + vbQuestion, "Dashboard Update")
    If Proceed1 = vbYes Then
        
        Proceed2 = MsgBox("Have you Deleted Data from Input Sheet?", vbYesNo + vbQuestion, "Dashboard Update")
        If Proceed1 = vbYes Then
        
            Clear_Sheets
            Delete_NonActions
            Assignee_List
            FilterAndCopy
        Else: Exit Sub
        End If
    Else: Exit Sub
    End If
            
End Sub
    
Sub FilterAndCopy()
    'filter input table and copy rows to relevant tabs
        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
        
        
    Dim lngLastRow As Long
    Dim ToDoSheet As Worksheet, InProgressSheet As Worksheet, ClosureSheet As Worksheet, ClosedSheet As Worksheet 'add/remove/update sheet names as needed
        
        
    Set ToDoSheet = Sheets("To Do") ' Set This to the Sheet name you want all To Do's going to
    Set InProgressSheet = Sheets("In Progress") ' Set this to the Sheet name you want all In Progress's going to
    Set ClosureSheet = Sheets("Closure Review") ' Set this to the Sheet name you want all Closure Reviews going to
    Set ClosedSheet = Sheets("Closed") ' Set this to the Sheet name you want all Closed going to
        
    lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
        
        
    With Range("A1", "M" & lngLastRow)
        .AutoFilter
        .AutoFilter Field:=4, Criteria1:="To Do" 'Autofilter field refers to the column number
        .Copy ToDoSheet.Range("A1")              'Sheet and cell data will be copied to
        .AutoFilter Field:=4, Criteria1:="In Progress"
        .Copy InProgressSheet.Range("A1")
        .AutoFilter Field:=4, Criteria1:="Closure Review"
        .Copy ClosureSheet.Range("A1")
        .AutoFilter Field:=4, Criteria1:="Done"
        .Copy ClosedSheet.Range("A1")
        .AutoFilter
    End With
        
        
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
        
End Sub
    
Sub Clear_Sheets()
        
    'clears values from specific sheets while preserving formatting
        
    Sheets("To Do").Cells.ClearContents
    Sheets("In Progress").Cells.ClearContents
    Sheets("Closure Review").Cells.ClearContents
    Sheets("Closed").Cells.ClearContents
    Sheets("Input List").Cells.ClearContents
        
End Sub
        
    
Sub Delete_NonActions()
        
    'find specific cell values in column A of the Input Sheet and deletes rows
        
    Dim Row As Long
    Dim i As Long
        
    Row = Cells(Rows.Count, "A").End(xlUp).Row
        
    For i = Row To 1 Step -1
        If Cells(i, 1) = "Transfer Document" Then
            Rows(i).Delete
        End If
    Next
        
    For i = Row To 1 Step -1
        If Cells(i, 1) = "Outgoing Data Request" Then
            Rows(i).Delete
        End If
    Next
        
    For i = Row To 1 Step -1
        If Cells(i, 1) = "Incoming Data Request" Then
            Rows(i).Delete
        End If
    Next
        
End Sub
    
Sub Assignee_List()
        
    'Copies the list of action assignees from the Input Sheet and creates a list of unique entries to create Assignee dropdown list on the dashboard
        
    Sheets("Input Sheet").Range("F1:F65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Input List").Range("A1"), Unique:=True
        
    Sheets("Input List").Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants).Select
        
    Dim tbl As ListObject
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
    'tbl.TableStyle = "TableStyleMedium15"
    tbl.DisplayName = "Assignee_List"
        
End Sub
        
Sub Burndown_Snapshot()
    'Copies the Overall Status Summary Data from the Dashboard and adds to the next empty column of the Historic Status table
    'Triggered by the 'Burndown Snapshot' button on the dashboard
        
    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Dashboard")
    Dim srg As Range: Set srg = sws.Range("C3:C7")
            
    Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("Historic Status")
    Dim lCell As Range
    Set lCell = dws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious)
    If lCell Is Nothing Then Exit Sub ' no data in range
    Dim dCell As Range: Set dCell = dws.Cells(1, lCell.Column + 1)
    Dim drg As Range: Set drg = dCell.Resize(srg.Rows.Count, srg.Columns.Count)
            
    drg.Value = srg.Value
        
End Sub

使用字典获取表中唯一列值

Sub Assignee_List()
    ' Copies the list of action assignees from the Input Sheet and creates a list 
    ' of unique entries to create Assignee dropdown list on the dashboard.

    ' Source        
    Const sName As String = "Input Sheet"
    Const sFirstCellAddress As String = "F1"
    ' Destination
    Const dName As String = "Input List"
    Const dTblName As String = "Assignee_List"
    Const dFirstCellAddress As String = "A1"
    Const dTitle As String = ""
    
    ' Reference the source worksheet.
    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(sName)
    
    Dim Data As Variant
    Dim rCount As Long
    
    ' Write the values from the source range to an array.
    With sws.Range(sFirstCellAddress)
        Dim lCell As Range
        Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub ' no data in column range
        rCount = lCell.Row - .Row + 1
        If rCount < 2 Then Exit Sub ' only headers
        Data = .Resize(rCount).Value
    End With
    
    ' Write the unique values from the array to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 2 To rCount
        Key = Data(r, 1)
        If Not IsError(Key) Then ' exclude errors
            If Len(Key) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only errors and blanks
    
    ' Write the header, and the data from the dictionary to an array.
    
    rCount = dict.Count + 1
    
    Dim dHeader As String
    
    If Len(dTitle) = 0 Then
        dHeader = Data(1, 1)
    Else
        dHeader = dTitle
    End If
    
    ReDim Data(1 To rCount, 1 To 1)
    Data(1, 1) = dHeader
    r = 1
    
    For Each Key In dict.Keys
        r = r + 1
        Data(r, 1) = Key
    Next Key
    
    ' Write the values from the array to the destination range.
    
    ' Reference the destination worksheet.
    Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets(dName)
    
    ' Delete previous table.
    On Error Resume Next
        dws.ListObjects(dTblName).Delete
    On Error GoTo 0
    
    Dim tbl As ListObject
    
    With dws.Range(dFirstCellAddress)
        ' Write values.
        .Resize(rCount).Value = Data
        ' Clear below.
        .Resize(dws.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
        ' Convert to table.
        Set tbl = dws.ListObjects.Add(xlSrcRange, .Resize(rCount), , xlYes)
    End With
    
    With tbl
        .DisplayName = dTblName
        .TableStyle = "TableStyleMedium15"
        .ListColumns(1).Range.EntireColumn.AutoFit
    End With
    
End Sub

excel 为什么代码给出400错误，但在调试模式下运行

1条答案

使用字典获取表中唯一列值

相关问题

热门标签

最新问答