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

  • 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)
    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)
    Set Src = Nothing
    Set dst = Nothing
    If conODBC.State <> 0 Then
    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
            .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
    If rst.State <> 0 Then
    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
    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
    ' 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)
    sqlQuery = Replace(sqlQuery, "AND POS.GRP_SPLIT_ID = 7754843", "")
    End If
    If account = "ZZ" Then
    sqlQuery = Replace(sqlQuery, "AND AC.ACCNT_NAME = 'ZZ'", "")
    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
    Set fso = Nothing
    Set stream = Nothing
    read_sql = sqlQuery
    End Function

    Monday, January 12, 2015 7:58 AM

All replies

  • You have declared the variable conODBC at the modul level, means the memory manager can not release this variable.

    Set the variable to Nothing at the end of your sub get_positions.


    Monday, January 12, 2015 4:13 PM
  • Thanks for the Reply. However excel still crashes after closing it. Is there a way to check whats using up memory within excel itself?


    Tuesday, January 13, 2015 3:33 PM
  • Hi kadimar,

    First, please disable screen updating and events. (At the end or in exception code, enable them)



    Secondly, there are some tools could analyze process, memory and so on that may help you:

    # Spy++


    # Process Explorer




    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Wednesday, January 14, 2015 3:01 AM
  • Thanks for the links,

    I tried to move conODBC from public into a Sub but still Excel keeps crashing after I close it although all steps of the macro execute fine and the sheet is fine and usable after the execution.

    Still have no clue whats wrong.


    Friday, January 16, 2015 7:37 AM
  • Hi Mark,

    I think we need to narrow down this issue, please remove the object model code (leaving the OLEDB code, e.g. connect to database, retrieve data from database), then to check whether it still has the issue. If the issue has gone, then add part object model code at once, then check again.

    On the other hand, you may consider to use document-level add-in to achieve that if it needs to load too much large data.



    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Wednesday, January 21, 2015 6:33 AM
  • 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
    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
    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


    Wednesday, January 21, 2015 12:09 PM