'Why code gives 400 error, but runs in debug mode
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
Solution 1:[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
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 |
