Excel application won't terminate (memory resident )

Excel application should have terminated after xlApp.quit and cleaned after set xlApp=nothing


tblSample
Name      Amount      Cost
AAAAA      25652.7      6159.16
AAAAA      2652.7        159.16
BBBBB      3673.25        500.39
BBBBB      1673.25        100.39
CCCCC      3914.09        554.84
CCCCC      1914.09        114.84
DDDDD      2270.61        136.23
EEEEE      2087.28        125.23
FFFFF      1847.5        110.85
GGGGG      1606.03          96.36


Private Sub cmdTest_Click()
Dim Db As DAO.Database, Rs As DAO.Recordset
Dim i As Integer, j As Integer
Dim RsSql, strCellValue As String
Dim CurrentValue As Variant
Dim CurrentField As Variant
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
         
Set Db = DBEngine.Workspaces(0).Databases(0)
RsSql = "SELECT * FROM [tblSample]"
Set Rs = Db.OpenRecordset(RsSql, dbOpenDynaset)
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets("Sheet1")
    xlApp.Visible = True
j = 1
For i = 0 To Rs.Fields.Count - 1
    CurrentValue = Rs.Fields(i).Name
    xlSheet.Cells(j, i + 1).Value = CurrentValue
Next i
j = 2
Do Until Rs.EOF
    For i = 0 To Rs.Fields.Count - 1
        CurrentField = Rs(i)
        xlSheet.Cells(j, i + 1).Value = CurrentField
    Next i
    Rs.MoveNext
    j = j + 1
Loop
   
SubTotal xlSheet
InsertRows xlSheet    ' --------- this sub is the one causing the Excel
                               ' --------- application to become memory resident.
                               

'print sheet
    'xlSheet.PrintOut
         'xlBook.Saved = True
         xlBook.SaveAs "C:\Test.xls"
         Set xlSheet = Nothing
         Set xlBook = Nothing
        xlApp.Quit
         Set xlApp = Nothing
    Rs.Close
    Db.Close
End Sub
---------------------------------------------
Private Sub InsertRows(xlSheet As Object)
Dim FirstItem, SecondItem As String
Dim r, j As Integer

With xlSheet
    .Range("A2").Activate
   FirstItem = ActiveCell.Value
   SecondItem = ActiveCell.Offset(1, 0).Value
   r = 1
   Do While ActiveCell <> ""
      If FirstItem = SecondItem Then
          r = r + 1
        SecondItem = ActiveCell.Offset(r, 0).Value
      Else
        ActiveCell.Offset(r, 0).EntireRow.Font.Bold = True
        ActiveCell.Offset(r + 1, 0).Select
        ActiveCell.EntireRow.Insert
      r = 1
        FirstItem = ActiveCell.Offset(r, 0).Value
        SecondItem = ActiveCell.Offset(r + 1, 0).Value
        ActiveCell.Offset(1, 0).Select
      End If
   Loop
  End With
 
End Sub
-------------------------------------------
Private Sub SubTotal(xlSheet As Object)
With xlSheet
    With .Range("A1").CurrentRegion
        .SubTotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2, 3), Replace:=True, PageBreaks:=False, SummaryBelowData _
        :=True
    End With
End With

End Sub
Start Free Trial