Memory usage of excel stays high after Macro is executed and excel crashes after trying to close it

Question

Hi,
I'm trying to resolve an issue with an excel based tool. The macros retrieve data from an Oracle database and do calculations with the data. They also open and write into files in the same directory. The macros all run and finish the calculations. I can
continue to use and modify the sheet. I can also close the workbook, however excel memory usage I see in the windows Task manager stays elevated.If I  close Excel it says: Excel stopped working and then it tries to recover information...
I assume something in the macro did not finish properly and memory was not released. I would like to check what is still open (connection, stream or any other object) when I close the workbook I would like to have a list of all still used memory. Is there
a possibility to do so.
Here the code I'm using, its reduced to functions which open something. Functions   
get_v_tools() and get_change_tools() are same as get_client_positions().
Public conODBC As New ADODB.Connection
Public myPath As String
Sub get_positions()
Dim Src As range, dst As range
Dim lastRow As Integer
Dim myPath As String
lastRow = Sheets("SQL_DATA").Cells(Sheets("SQL_DATA").rows.Count, "A").End(xlUp).Row
Sheets("SQL_DATA").range("A2:AD" & lastRow + 1).ClearContents
Sheets("SQL_DATA").range("AG2:BE" & lastRow + 2).ClearContents
Sheets("SQL_DATA").range("AE3:AF" & lastRow + 2).ClearContents
k = Sheets("ToolsList").Cells(Sheets("ToolsList").rows.Count, "A").End(xlUp).Row + 1
Sheets("ToolsList").range("A2:M" & k).ClearContents
'open connection
Call open_connection
lastRow = Sheets("SQL_DATA").Cells(Sheets("SQL_DATA").rows.Count, "A").End(xlUp).Row
If lastRow < 2 Then GoTo ErrorHandling
'copy bs price check multiplications
Set Src = Sheets("SQL_DATA").range("AE2:AF2")
Set dst = Worksheets("SQL_DATA").range("AE2").Resize(lastRow - 1, Src.columns.Count)
dst.Formula = Src.Formula
On Error GoTo ErrorHandling
'new prices are calculated
newPrice_calculate (lastRow)
Calculate
myPath = ThisWorkbook.Path
'Refresh pivot table in Position Manager
Sheets("Position Manager").PivotTables("PivotTable3").ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
myPath & "\[Position_Manager_v1.0.xlsm]SQL_DATA!R1C2:R" & lastRow & "C31" _
, Version:=xlPivotTableVersion14)
ErrorHandling:
Set Src = Nothing
Set dst = Nothing
If conODBC.State <> 0 Then
conODBC.Close
End If
End Sub
Sub open_connection()
Dim sql_data, sql_data_change, sql_data_v As Variant
Dim wdth, TotalColumns, startRow As Integer
Dim rst As New ADODB.Recordset
Errorcode = 0
On Error GoTo ErrorHandling
Errorcode = 1
With conODBC
.Provider = "OraOLEDB.Oracle.1"
.ConnectionString = "Password=" & pswrd & "; Persist Security Info=True;User ID= " & UserName & "; Data Source=" & DataSource
.CursorLocation = adUseClient
.Open
.CommandTimeout = 300
End With
startRow = Sheets("SQL_DATA").Cells(Sheets("SQL_DATA").rows.Count, "A").End(xlUp).Row + 1
sql_data = get_client_positions(conODBC, rst)
wdth = UBound(sql_data, 1)
Sheets("SQL_DATA").range("A" & startRow & ":AA" & wdth + startRow - 1).Value = sql_data
'Run change tools instruments
startRow = Sheets("ToolsList").Cells(Sheets("ToolsList").rows.Count, "A").End(xlUp).Row + 1
sql_data_change = get_change_tools(conODBC, rst)
wdth = UBound(sql_data_change, 1)
Sheets("ToolsList").range("A" & startRow & ":M" & wdth + startRow - 1).Value _
= sql_data_change
'open SQL for V tools instruments
startRow = Sheets("ToolsList").Cells(Sheets("ToolsList").rows.Count, "A").End(xlUp).Row + 1
sql_data_v = get_v_tools(conODBC, rst)
wdth = UBound(sql_data_v, 1)
Sheets("ToolsList").range("A" & startRow & ":L" & startRow + wdth - 1).Value = sql_data_v
conODBC.Close
ErrorHandling:
If rst.State <> 0 Then
rst.Close
End If
Set rst = Nothing
End Sub
Private Function get_client_positions(conODBC As ADODB.Connection, rst_posi As ADODB.Recordset) As Variant
Dim sql_data As Variant
Dim objCommand As ADODB.Command
Dim sql As String
Dim records, TotalColumns As Integer
On Error GoTo ErrorHandling
Set objCommand = New ADODB.Command
sql = read_sql()
With objCommand
.ActiveConnection = conODBC 'connection for the commands
.CommandType = adCmdText
.CommandText = sql 'Sql statement from the function
.Prepared = True
.CommandTimeout = 600
End With
Set rst_posi = objCommand.Execute
TotalColumns = rst_posi.Fields.Count
records = rst_posi.RecordCount
ReDim sql_data(1 To records, 1 To TotalColumns)
If TotalColumns = 0 Or records = 0 Then GoTo ErrorHandling
If TotalColumns <> 27 Then GoTo ErrorHandling
If rst_posi.EOF Then GoTo ErrorHandling
l = 1
Do While Not rst_posi.EOF
For i = 0 To TotalColumns - 1
sql_data(l, i + 1) = rst_posi.Fields(i)
Next i
l = l + 1
rst_posi.MoveNext
Loop
ErrorHandling:
rst_posi.Close
Set rst_posi = Nothing
Set objCommand = Nothing
get_client_positions = sql_data
End Function
Private Function read_sql() As String
Dim sqlFile As String, sqlQuery, Line As String
Dim query_dt As String, client As String, account As String
Dim GRP_ID, GRP_SPLIT_ID As String
Dim fso, stream As Object
Set fso = CreateObject("Scripting.FileSystemObject")
client = Worksheets("Cover").range("C9").Value
query_dt = Sheets("Cover").range("C7").Value
GRP_ID = Sheets("Cover").range("C3").Value
GRP_SPLIT_ID = Sheets("Cover").range("C5").Value
account = Sheets("Cover").range("C11").Value
sqlFile = Sheets("Cover").range("C15").Value
Open sqlFile For Input As #1
Do Until EOF(1)
Line Input #1, Line
sqlQuery = sqlQuery & vbCrLf & Line
Loop
Close
' Replace placeholders in the SQL
sqlQuery = Replace(sqlQuery, "myClent", client)
sqlQuery = Replace(sqlQuery, "01/01/9999", query_dt)
sqlQuery = Replace(sqlQuery, "54747743", GRP_ID)
If GRP_SPLIT_ID <> "" Then
sqlQuery = Replace(sqlQuery, "7754843", GRP_SPLIT_ID)
Else
sqlQuery = Replace(sqlQuery, "AND POS.GRP_SPLIT_ID = 7754843", "")
End If
If account = "ZZ" Then
sqlQuery = Replace(sqlQuery, "AND AC.ACCNT_NAME = 'ZZ'", "")
Else
sqlQuery = Replace(sqlQuery, "ZZ", account)
End If
' Create a TextStream to check SQL Query
sql = sqlQuery
myPath = ThisWorkbook.Path
Set stream = fso.CreateTextFile(myPath & "\SQL\LastQuery.txt", True)
stream.Write sql
stream.Close
Set fso = Nothing
Set stream = Nothing
read_sql = sqlQuery
End Function

Answer 1

Thanks Starain,
that's what I did the last days and found that the problem is in the
newPrice_calculate (lastRow)
function. This function retrieves data (sets it as arrays) which was correctly pasted into the sheet, loops through all rows and does math/calendar calculations with cell values using an Add-In("Quantlib")
Public errorMessage as String
Sub newPrice_calculate(lastRow)
Dim Type() As Variant
Dim Id() As Variant
Dim Price() As Variant
Dim daysTo() As Variant
Dim fx() As Variant
Dim interest() As Variant
Dim ObjCalend as Variant
Dim newPrice as Variant
On Error GoTo Catch
interest = Sheets("SQL_DATA").range("V2:V" & lastRow).Value
Type = Sheets("SQL_DATA").range("L2:L" & lastRow).Value Id = Sheets("SQL_DATA").range("M2:M" & lastRow).Value Price = Sheets("SQL_DATA").range("T2:T" & lastRow).Value
daysTo = Sheets("SQL_DATA").range("K2:K" & lastRow).Value
fx = Sheets("SQL_DATA").range("U2:U" & lastRow).Value
qlError = 1
For i = 2 To lastRow
If (i, 1) = "LG" Then
'set something - nothing spectacular like
interest(i, 1) = 0
daysTo(i , 1) = 0
Else
adjTime = Sqr(daysTo(i, 1) / 365)
ObjCalend(i,1) =Application.Run("qlCalendarHolidaysList", _
"CalObj", ... , .... other input parameters)
If IsError(ObjCalend(i,1)) Then GoTo Catch
'other calendar calcs
newPrice(i,1) = Application.Run( 'quantLib calcs)
End If
Catch:
Select Case qlError
Case 1
errorMessage = errorMessage & " QuantLibXL Cal Error at: " & i & " " & vbNewLine & Err.Description
ObjCalend(i,1) (i, 1) = "N/A"
End Select
Next i
Sheets("SQL_DATA").range("AB2:AB" & lastRow).Value = newPrice
'Sheets("SQL_DATA").range("AA2:AA" & lastRow).Value = daysTo
' erase and set to nothing all arrays and objects
Erase Type
Erase id
Erase Price
Set newPrice = Nothing
Is there a possibility to clean everything in:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
End Sub
Thanks in advance
Mark