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