Re-Purposed Code - ActiveX Cannot Create Object help

[CatLadee]

I am re-using code that I had used in the past sucessfully. The purpose is to break a spreadsheet intonumerous files based on the value in column A. I am getting the error message “RunTime Error 429 – ActiveX cannot create object” for the bolded item below. The main table to be split up is on Tab HSIand the table is named AgingTable. Any idea why this isn’t working? Really appreciate your help! Lindsay

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFilePicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFileLocation = sItem
    Set fldr = Nothing
    Range("B3") = sItem
End Function

Sub CreateTemplates()
  
  GetFolder

'Declare local variables
'-----------------------------
Dim arrDataSet() As Variant
Dim lo As ListObject
Dim Wb As Workbook
Dim dictionary As Object
Dim strKey As Variant
'-----------------------------

'Turn off application settings
'----------------------------------
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'----------------------------------
'Set all list object, dictionary, and array variables
'----------------------------------------------------------------------
[B]Set lo = ThisWorkbook.Worksheets("HSI").ListObjects("AgingTable")[/B]
arrDataSet = lo.DataBodyRange.Value
Set dictionary = CreateObject("Scripting.Dictionary")
'----------------------------------------------------------------------

'Loop through all of the Agency column to find the unique values
'------------------------------------------------------
On Error Resume Next
For i = 1 To UBound(arrDataSet, 1)
    'Add unique values to dictionar
    dictionary.Add arrDataSet(i, 17), arrDataSet(i, 17)
    
    'If value already exists, skip error and continue
    If Err.Number = 457 Then
        Err.Clear
    'If other error stop code
    ElseIf Err.Number <> 457 And Err.Number <> 0 Then
        Stop
    End If
    
Next i
'------------------------------------------------------
'
''This is the item we are filtering out
'strFilterOut = "LEAP eligible per OHC and certification approved in ICM (active profile) "
'Open template workbook
Set Wb = Workbooks.Open(ThisWorkbook.Worksheets("Code Navigation Tab").Range("B3").Value)
'Copy and paste all unique filter items to template workbook
'-----------------------------------------------------------------------------------------------------------------
For Each strKey In dictionary.Keys
    'Filter each unique location rollup
    lo.Range.AutoFilter Field:=1, Criteria1:=strKey
'    'Filter out criteria set above
'    lo.Range.AutoFilter Field:=14, Criteria1:="<>" & strFilterOut
    'Copy data from source workbook
    lo.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
    
    'Copy all visible rows
    Wb.Worksheets("Sheet1").UsedRange.Rows(Wb.Worksheets("Sheet1").UsedRange.Rows.Count + 1).PasteSpecial xlPasteValues
    
    'Save workbook as new workbook
    Wb.SaveCopyAs Wb.Path & "\AI_" & strKey & ".xlsm"
    'Remove old values and begin next unique location rollup
    Wb.Worksheets("Sheet1").Range(Wb.Worksheets("Sheet1").Cells(2, 1), Wb.Worksheets("Sheet1").Cells(Wb.Worksheets("Sheet1").Rows.Count, Wb.Worksheets("Sheet1").Columns.Count).Address).Clear
Next strKey
'-----------------------------------------------------------------------------------------------------------------
'Close template workbook and turn off filters
Wb.Close
lo.Range.AutoFilter
'Turn on application updates
'--------------------------------
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'--------------------------------
'


End Sub

 

[bobsan42]

try to change Dim lo As ListObject with:

[B]Dim lo as Object[/B]

or

Dim lo as Excel.ListObject