1

I am having an issue where the below code will run fine in debug mode, but is throwing a 400 Error when activated normally. It keeps getting stuck on the Sub Assignee_List part of the code specifically the Sheets("Input List").Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants).Select line. I have no idea why.

Sorry for posting the large block of code, but I have no idea what parts are causing the issue. As far as I can tell from my locals window during debug, the code isn't pulling any values from other subs, into the Assignee_List sub.

For context the Assignee_List sub looks at the name of a staff member assigned to a list of tasks and filters it to a list of unique values (each name appears once) then turns the list into a named range to support a data validation list elsewhere in the workbook

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
    
VBasic2008
  • 44,888
  • 5
  • 17
  • 28
Icaruim14
  • 51
  • 8
  • What does it do? – VBasic2008 May 10 '22 at 06:59
  • In order of operations it clears the text from certain sheets (Clear_Sheets sub), then deletes irrelevant entries (Delete_NonActions sub). It then looks at the column which indicates who is responsible for a task and filters that column to unique values and pastes the filtered list onto a new sheet, then names that range (Assignee_List sub). Finally it looks at the status column and filters and pastes the tasks onto a sheet based on the status value (FilterandCopy sub) – Icaruim14 May 10 '22 at 07:03
  • IMO you have an error because of a `.Select` at the end of the mentioned line. I think that the addressed sheet isn't active at the moment of executing this part. Try to add `Sheets("Input List").Activate` before. – Vitalizzare May 10 '22 at 07:20
  • @Vitalizzare adding that give me a 438 runtime error, but I agree with your point about the .select being the problem. Not sure how to rewrite to remove it though – Icaruim14 May 10 '22 at 07:29
  • 1
    Is the error number really 400? Not 1004? If so, 400 is a strange error, very difficult to debug. Please, try moving the code in a new module and run it. If previously selecting the sheet in discussion (manually), does the code raise any error? – FaneDuru May 10 '22 at 07:43

1 Answers1

1

Get Unique Column Values Into a Table Using a Dictionary

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
VBasic2008
  • 44,888
  • 5
  • 17
  • 28