The excel.exe*32 process remains open in the Windows Task Manager even though I am closing it in VBA. I am running the following VBA code from Access. I have looked and tried various solutions to no avail. The only way to close excel.exe is to quit Access. Can someone point out what I am missing.
Public Sub GenerateQualityReportsSub()
On Error GoTo ERR_GenerateQualityReportsSub
Dim xl As Excel.Application
Dim wbk As Excel.Workbook
Dim dbs As DAO.Database
Dim rstRpt As DAO.Recordset
Dim objMyRange As Object
Dim rstList As DAO.Recordset
Dim FullOutFileName As String
Dim strSQLList As String
Dim strSQLRpt As String
Dim i As Integer
Dim DiscrepancyRecords As Long
Dim NeedToCloseExcel As Boolean
Dim ReportName As String
Dim col As Integer
'Initialize Variables
Set dbs = CurrentDb
RunDate = Now()
FullOutFileName = "DataQualityDiscrepancyReport.xlsx"
i = 0
DiscrepancyRecords = 0
NeedToCloseExcel = False
'Determine the Reports to Generate
strSQLList = "" & _
"SELECT ReportNum, ReportName, SheetName, QueryName, [Responsible Department] " & _
"FROM [Data Quality Reports] " & _
"ORDER BY ReportNum"
Set rstList = dbs.OpenRecordset(strSQLList, dbOpenSnapshot, dbReadOnly)
If rstList.RecordCount = 0 Then
i = 0
GoTo Exit_GenerateQualityReportsSub
Else
'Open Excel
Set xl = New Excel.Application 'Open the Excel File
xl.Visible = True 'Make Excel Invisible to User
'Create the Excel Spreadsheet and Sheets
Set wbk = xl.Workbooks.Add 'Add a Wookbook to the Excel File
wbk.Sheets("Sheet1").Select 'Select Sheet 1
wbk.SaveAs FileName:=FullOutFileName 'Save the Excel File
NeedToCloseExcel = True
End If
'Create One Sheet Per Report
i = 1
While Not rstList.EOF
DiscrepancyRecords = 0
'Add, if necessary, and Rename the Sheet
If i <> 1 Then
Set wks = xl.Worksheets.Add 'Add a Wooksheet to the Excel File
End If
wbk.Sheets("Sheet" & i).Select 'Select the new Sheet
wbk.Sheets("Sheet" & i).Name = rstList("SheetName") 'Rename the Sheet
Set wks = wbk.activesheet
'Obtain and Write Data to the Excel Sheet
strSQLRpt = "Select * from [" & rstList("QueryName") & "]"
Set objMyRange = wks.Cells(xl.activesheet.UsedRange.Rows.Count + 1, 1)
Set rstRpt = dbs.OpenRecordset(strSQLRpt, dbOpenSnapshot, dbReadOnly)
If rstRpt.RecordCount = 0 Then
GoTo Exit_GenerateQualityReportsSub
Else
rstRpt.MoveLast
DiscrepancyRecords = rstRpt.RecordCount
rstRpt.MoveFirst
End If
'Write the Column Headers to the Sheet
For col = 0 To rstRpt.Fields.Count - 1
wks.Cells(1, col + 1) = rstRpt.Fields(col).Name
Next col
'Write Data to the Excel Sheeet
Range("A2").Select
With objMyRange
rstRpt.MoveFirst
.CopyFromRecordset rstRpt
End With
'Format the Sheet Cells
Cells.Select
Selection.Columns.AutoFit
Range("A1").Select
'Save the Excel File
wbk.Save 'Save the Excel File
NextReport:
'Close the Data Results
rstRpt.Close
Set rstRpt = Nothing
rstList.MoveNext
i = i + 1
Wend
i = i - 1
'Close the Excel File and Application
xl.Visible = True
wbk.Save
wbk.Close savechanges:=True
xl.Quit
Set wks = Nothing
DoEvents
Set wbk = Nothing
DoEvents
Set xl = Nothing
DoEvents
NeedToCloseExcel = False
'Close the Report Record
rstList.Close
Set rstList = Nothing
Exit_GenerateQualityReportsSub:
If NeedToCloseExcel Then
xl.Visible = True
wbk.Save
wbk.Close savechanges:=True
xl.Quit
Set wks = Nothing
DoEvents
Set wbk = Nothing
DoEvents
Set xl = Nothing
DoEvents
NeedToCloseExcel = False
End If
Exit Sub
ERR_GenerateQualityReportsSub:
.....
End Sub