Consulting

Results 1 to 5 of 5

Thread: VBA API Macro Inconsistent

  1. #1
    VBAX Regular
    Joined
    Dec 2012
    Posts
    35
    Location

    Exclamation VBA API Macro Inconsistent

    Hello! I'm still a relative VBA novice and have a very important task of obtaining large amounts of data out of a software using API. I really need assistance and have run out of resources so I'm turning to my friends here for help!

    I'm running into a variety of errors, but I believe that 'no more threads can be created in system' is the culprit. We're using a virtual network, Excel64 bit, and 16GB memory. I have a feeling the process is taking up too many resources and is breaking early. Does anyone have any experience with API or threads? I have no idea where to start

    I'm hoping to at least get some suggestions for a more efficient macro -- any ideas?! Would really appreciate any thoughts you may have.

    Highlighted is where the code break..

    Public SoftwareProject As New SoftwareSystem
    
    
    Sub DoRead()
           
        Dim file As String, location As String
        Dim product As String
        Dim TableNAme As String
        Dim tabletype As String
        Dim AlternateRangeName As String
        Dim fullpath As String
        Dim Company As String
        Dim Description As String
        Dim parameter As Variant
        Dim rows As Integer
        Dim SheetRows As Integer
        Dim CurrentRow As Integer
        Dim tRow As Integer
        Dim cell As Range
        Dim i As Integer
        Dim j As Integer
        Dim mainworkBook As Workbook
        Dim ws As Worksheet
        Dim NumRows As Integer
        Dim NumCols As Integer
        Dim MyRange As Range
        Dim createsheet As String
        Dim sheetExists As String
        
        On Error GoTo Error_handler
           
        
         Application.ScreenUpdating = False
         Application.Calculation = xlCalculationAutomatic
         Application.DisplayStatusBar = False
         Application.EnableEvents = True
         ActiveSheet.DisplayPageBreaks = False
         
     
        file = ""
        location = ""
        product = ""
        TableNAme = ""
        tabletype = ""
        AlternateRangeName = ""
        fullpath = ""
        Company = ""
        CurrentRow = 1
        NumRows = 0
        NumCols = 0
        tRows = 0
        tCols = 0
        tRow = 2
            
        Sheets("Mylist").Range("eval").Value = Userform.EvalDate.Value
        Sheets("Mylist").Range("TableName").Value = Userform.TableNAme.Value
        
        Set mainworkBook = ActiveWorkbook
        Sheets("Data").Range("Datarange").ClearContents
        parameter = Range("report")
        ParamRows = Range("report").rows.Count - 1
        FileRows = Range("files").rows.Count
        
        For rows = 2 To ParamRows + 1
        
            file = parameter(rows, 1)
            location = parameter(rows, 2)
            product = parameter(rows, 3)
            
            If product = "" Then Exit For
            
            TableNAme = parameter(rows, 4)
            tabletype = ""
            fullpath = location & "\" & file
            parameter(rows, 6) = Replace(parameter(rows, 6), " ", "")
            AlternateRangeName = parameter(rows, 6)
            If FileOrDirExists(location & "\" & file) Then
                Call ReadExecute(CurrentRow, tRow, fullpath, product, TableNAme, tabletype)
            End If
        Next rows
        
        'Refreshfile @ end
        For i = 1 To FileRows
            file = Range("files").Cells(i, 1).Value
            location = Range("files").Cells(i, 2).Value
            If file <> "" And location <> "" And Dir(location & "\" & file & ".apj") <> "" Then
                    SoftwareProject.RefreshFile (location & "\" & file & ".apj")
            End If
        Next i
        
        Exit Sub
         Application.ScreenUpdating = True
         Application.Calculation = xlCalculationAutomatic
         Application.DisplayStatusBar = True
         Application.EnableEvents = True
         ActiveSheet.DisplayPageBreaks = False
    
         
    'Refreshfile on error
    Error_handler:
        ErrMsg = "ERROR WITH THE TABLE ON ROW " & i
        MsgBox ErrMsg, vbCritical, "ERROR"
        If fullpath <> "" Then
            SoftwareProject.RefreshFile (fullpath)
        End If
        
    End Sub
    
    Sub ReadExecute(ByRef CurrentRow As Integer, tRow As Integer, fullpath As String, product As String, TableNAme As String, tabletype As String)
        Dim AlternateRangeName As String
        Dim Company As String
        Dim Description As String
        Dim parameter As Variant
        Dim rows As Integer
        Dim SheetRows As Integer
        Dim cell As Range
        Dim i As Integer
        Dim j As Integer
        Dim mainworkBook As Workbook
        Dim ws As Worksheet
        Dim NumRows As Integer
        Dim NumCols As Integer
        Dim MyRange As Range
        Dim createsheet As String
        Dim sheetExists As String
        
        Sheets("Data").Select
        
        If NumRows = 0 Then
            NumRows = SoftwareProject.NumRows(fullpath, product, "REPORT", TableNAme)
            NumCols = SoftwareProject.NumColumns(fullpath, product, "REPORT", TableNAme)
        Else
        End If
        
            
            If CurrentRow = 1 Then
                Set MyRange = ActiveSheet.Range(Cells(CurrentRow + 1, 4), Cells(CurrentRow + NumRows, 4))
                    MyRange.Range(Cells(1, 1), Cells(NumRows, 1)).Value = product
            Else
                Set MyRange = ActiveSheet.Range(Cells(CurrentRow, 4), Cells(CurrentRow + NumRows, 4))
                    MyRange.Range(Cells(1, 1), Cells(NumRows, 1)).Value = product
            End If
                
    'Column Labels
            If CurrentRow = 1 Then
            Set MyRange = ActiveSheet.Range(ActiveSheet.Cells(CurrentRow, 6), ActiveSheet.Cells(CurrentRow, NumCols + 5))
                HeadersRec = SoftwareProject.ColumnLabels(fullpath, product, "REPORT", TableNAme)
                MyRange.Value = HeadersRec
                'for t data
                
    'Row Labels & Table Data
            If CurrentRow = 1 Then CurrentRow = CurrentRow + 1 Else CurrentRow = CurrentRow
            End If
            Set MyRange = ActiveSheet.Range(ActiveSheet.Cells(CurrentRow, 5), ActiveSheet.Cells(CurrentRow + NumRows - 1, 5))
                RowsRec = SoftwareProject.RowLabels(fullpath, product, "REPORT", TableNAme)
                MyRange = Application.Transpose(RowsRec)
        
            
            Set MyRange = ActiveSheet.Range(ActiveSheet.Cells(CurrentRow, 6), ActiveSheet.Cells(CurrentRow + NumRows - 1, NumCols + 5))
                tbleData = SoftwareProject.Data(fullpath, product, "REPORT", TableNAme)
                MyRange.Value = tbleData
            
         
        
           CurrentRow = CurrentRow + NumRows
           file = ""
           location = ""
           product = ""
           TableNAme = ""
           tabletype = ""
           AlternateRangeName = ""
           fullpath = ""
           Set MyRange = Nothing
           
        
    End Sub
    Last edited by mikeoly; 01-21-2019 at 11:08 AM.

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    One easy thing to try is to comment out the On Error Goto Error_Handler statement at the beginnng and see where it fails

    Personally, I don't like to put an On Error at the beginning (esp On Error Resume Next) but only around very small block of code where I know if I get an error it'll be OK.

    Just a thought
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    VBAX Regular
    Joined
    Dec 2012
    Posts
    35
    Location
    Thanks!

    Edit: Errors I'm getting...

    'Error 462: The remote server does not exist" error
    'Automation error, Unspecified error"
    'Automation error, No more threads can be created in the system"

    This occurs when setting NumRows line of Sub ReadExecute().
    Last edited by mikeoly; 01-21-2019 at 10:42 AM.

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Are you sure that your variables are consistent (tRow instead of tRows for example)

    Put Option Explicit at the top of the module and see if it finds any undeclared variables
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  5. #5
    VBAX Master Aflatoon's Avatar
    Joined
    Sep 2009
    Location
    UK
    Posts
    1,720
    Location
    I'd recommend you never declare a variable As New ...
    Always declare and initialize separately and explicitly. So:

    Public SoftwareProject as SoftwareSystem
    then in your ReadExecute routine, check the variable:

    If SoftwareProject Is Nothing then Set softwareproject = new softwaresystem
    Be as you wish to seem

Posting Permissions

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