Re-Purposed Code - ActiveX Cannot Create Object help

CatLadee

New Member
Joined
Sep 7, 2018
Messages
29


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



Code:
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
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
try to change Dim lo As ListObject with:
Code:
[B]Dim lo as Object[/B]
or
Code:
Dim lo as Excel.ListObject
 
Upvote 0

Forum statistics

Threads
1,213,483
Messages
6,113,919
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top