Thanks Thanks:  0
Likes Likes:  0
Results 1 to 2 of 2

Thread: Re-Purposed Code - ActiveX Cannot Create Object help

  1. #1
    New Member CatLadee's Avatar
    Join Date
    Sep 2018
    Location
    Washington, DC, USA
    Posts
    29
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re-Purposed Code - ActiveX Cannot Create Object help



    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
    '----------------------------------------------------------------------
    Set lo = ThisWorkbook.Worksheets("HSI").ListObjects("AgingTable")
    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

  2. #2
    Board Regular bobsan42's Avatar
    Join Date
    Jul 2010
    Location
    Bulgaria, GMT+2 (42.891813,25.313594)
    Posts
    1,251
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Re-Purposed Code - ActiveX Cannot Create Object help

    try to change Dim lo As ListObject with:
    Code:
    Dim lo as Object
    or
    Code:
    Dim lo as Excel.ListObject
    "...it's sad that in our blindness we gather thorns for flowers..."
    mostly using:
    windows 7 +10 (64-bit) / excel 2013 +2016 (32-bit) / access 2013 +2016 (32-bit) / some imagination & Google of course
    You don't need to read between the lines - just read them all!

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •