Excel Remains Open until Access is Closed...

  • Thread starter Thread starter Steven Britton via AccessMonster.com
  • Start date Start date
S

Steven Britton via AccessMonster.com

I have a function that export a spreadsheet through TransferSpreadsheet,
after I export the sheet I go out and pretty it up so that when the user
opens it the formatting is done for them.

The problem that I have is that after the export, Excel remains open as a
process in the task manager - However this process will terminate when I
close the Access database. I have some easy fixes in mind, but wanted to
refer to the masses first to see if anyone else has experienced this and if
there is a fix out there.

Thanks

-Steve


Option Compare Database
Option Explicit

Dim db As DAO.Database
Dim rs As DAO.Recordset

Dim strPath As String, j As String, k As String
Dim myDate As String, mySource As String
Dim strPartNumUp As String, strPartNumDown As String
Dim End_Row As Long, r As Long
Dim xlsApp As Object, wkbTemp As Object

Function SendInvStsRpttoExcel()
On Error Resume Next

DoCmd.SetWarnings False

Set db = CurrentDb()
'Checks for export directory
If Len(Dir("C:\My Documents", vbDirectory)) = 0 Then
' Directory doesn't exist. Create It
MkDir ("C:\My Documents")
End If

myDate = Format(Date, "mm-dd-yy")
mySource = "Inventory Status"
'Naming of file
strPath = "C:\My Documents\" & myDate & " " & mySource & ".xls"
'If file with today's date exist delete it - Used for possible updated
report later in the day
If Len(Dir(strPath)) > 0 Then
Kill strPath
End If

'Delete Old Export Table
db.Execute "DELETE FROM tblInvStsRpt;"
'Make New Export Table
DoCmd.OpenQuery "qryAppendInvStsRpt"

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"tblInvStsRpt", strPath

Set xlsApp = CreateObject("Excel.Application")

xlsApp.Visible = False

xlsApp.UserControl = True

Set wkbTemp = xlsApp.Workbooks.Open(strPath)

xlsApp.ActiveWindow.Zoom = 85
'Delete AutoNumbers
xlsApp.Columns("A:A").Select
xlsApp.Selection.Delete Shift:=xlToLeft
xlsApp.Range("A1").Select
xlsApp.Selection.End(xlDown).Select
'Find end of file
End_Row = ActiveCell.Row

'r = 2 to skip header row
r = 2
Do Until r > End_Row
strPartNumUp = ActiveSheet.Cells(r, 1).Value
strPartNumDown = ActiveSheet.Cells(r + 1, 1).Value
j = Empty
k = Empty
If strPartNumUp = strPartNumDown Then

Do Until j <> k
'Used in formating report for readabilty - Removes Part
Number if Mulit PO's
j = strPartNumUp
k = ActiveSheet.Cells(r + 1, 1).Value
If j = k Then
'Make Lines between Parts
Range("A" & r + 1 & ":" & "D" & r + 1).Select
xlsApp.Selection.ClearContents
Else: Exit Do
End If
r = r + 1
Loop
'Make Lines between Parts
Range("A" & r - 1 & ":" & "I" & r - 1).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

ElseIf strPartNumUp <> strPartNumDown Then
'Make Lines between Parts
Range("A" & r & ":" & "I" & r).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
r = r + 1
End If

Loop

'This is conditional formating if the Inv_Qty is equal to zero
'and there are no current PO's outstanding
xlsApp.Columns("D:D").Select
xlsApp.Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=
$J1=1"
xlsApp.Selection.FormatConditions(1).Interior.ColorIndex = 40
xlsApp.Columns("E:E").Select
xlsApp.Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=
$J1=1"
xlsApp.Selection.FormatConditions(1).Interior.ColorIndex = 40
xlsApp.Range("J2").Select
xlsApp.ActiveCell.FormulaR1C1 = "=IF(AND(RC[-6]=0,RC[-5]=""None""),1,0)"
xlsApp.Range(Selection, Selection.End(xlDown)).Select
xlsApp.Selection.FillDown
xlsApp.Cells.Select
xlsApp.Cells.EntireColumn.AutoFit

ActiveWorkbook.Save

wkbTemp.Save
wkbTemp.Close False
Set wkbTemp = Nothing
xlsApp.Quit
Set xlsApp = Nothing

DoCmd.SetWarnings True

End Function
 
"Steven Britton via AccessMonster.com" <[email protected]>
wrote in message
I have a function that export a spreadsheet through
TransferSpreadsheet, after I export the sheet I go out and pretty it
up so that when the user opens it the formatting is done for them.

The problem that I have is that after the export, Excel remains open
as a process in the task manager - However this process will
terminate when I close the Access database. I have some easy fixes
in mind, but wanted to refer to the masses first to see if anyone
else has experienced this and if there is a fix out there.

Thanks

-Steve


Option Compare Database
Option Explicit

Dim db As DAO.Database
Dim rs As DAO.Recordset

Dim strPath As String, j As String, k As String
Dim myDate As String, mySource As String
Dim strPartNumUp As String, strPartNumDown As String
Dim End_Row As Long, r As Long
Dim xlsApp As Object, wkbTemp As Object

Function SendInvStsRpttoExcel()
On Error Resume Next

DoCmd.SetWarnings False

Set db = CurrentDb()
'Checks for export directory
If Len(Dir("C:\My Documents", vbDirectory)) = 0 Then
' Directory doesn't exist. Create It
MkDir ("C:\My Documents")
End If

myDate = Format(Date, "mm-dd-yy")
mySource = "Inventory Status"
'Naming of file
strPath = "C:\My Documents\" & myDate & " " & mySource & ".xls"
'If file with today's date exist delete it - Used for possible updated
report later in the day
If Len(Dir(strPath)) > 0 Then
Kill strPath
End If

'Delete Old Export Table
db.Execute "DELETE FROM tblInvStsRpt;"
'Make New Export Table
DoCmd.OpenQuery "qryAppendInvStsRpt"

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"tblInvStsRpt", strPath

Set xlsApp = CreateObject("Excel.Application")

xlsApp.Visible = False

xlsApp.UserControl = True

Set wkbTemp = xlsApp.Workbooks.Open(strPath)

xlsApp.ActiveWindow.Zoom = 85
'Delete AutoNumbers
xlsApp.Columns("A:A").Select
xlsApp.Selection.Delete Shift:=xlToLeft
xlsApp.Range("A1").Select
xlsApp.Selection.End(xlDown).Select
'Find end of file
End_Row = ActiveCell.Row

'r = 2 to skip header row
r = 2
Do Until r > End_Row
strPartNumUp = ActiveSheet.Cells(r, 1).Value
strPartNumDown = ActiveSheet.Cells(r + 1, 1).Value
j = Empty
k = Empty
If strPartNumUp = strPartNumDown Then

Do Until j <> k
'Used in formating report for readabilty - Removes
Part Number if Mulit PO's
j = strPartNumUp
k = ActiveSheet.Cells(r + 1, 1).Value
If j = k Then
'Make Lines between Parts
Range("A" & r + 1 & ":" & "D" & r + 1).Select
xlsApp.Selection.ClearContents
Else: Exit Do
End If
r = r + 1
Loop
'Make Lines between Parts
Range("A" & r - 1 & ":" & "I" & r - 1).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

ElseIf strPartNumUp <> strPartNumDown Then
'Make Lines between Parts
Range("A" & r & ":" & "I" & r).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
r = r + 1
End If

Loop

'This is conditional formating if the Inv_Qty is equal to zero
'and there are no current PO's outstanding
xlsApp.Columns("D:D").Select
xlsApp.Selection.FormatConditions.Add Type:=xlExpression,
Formula1:="= $J1=1"
xlsApp.Selection.FormatConditions(1).Interior.ColorIndex = 40
xlsApp.Columns("E:E").Select
xlsApp.Selection.FormatConditions.Add Type:=xlExpression,
Formula1:="= $J1=1"
xlsApp.Selection.FormatConditions(1).Interior.ColorIndex = 40
xlsApp.Range("J2").Select
xlsApp.ActiveCell.FormulaR1C1 =
"=IF(AND(RC[-6]=0,RC[-5]=""None""),1,0)" xlsApp.Range(Selection,
Selection.End(xlDown)).Select xlsApp.Selection.FillDown
xlsApp.Cells.Select
xlsApp.Cells.EntireColumn.AutoFit

ActiveWorkbook.Save

wkbTemp.Save
wkbTemp.Close False
Set wkbTemp = Nothing
xlsApp.Quit
Set xlsApp = Nothing

DoCmd.SetWarnings True

End Function
Click to expand...

You've got a lot of unqualified references to Excel properties and
methods in there; e.g.,
End_Row = ActiveCell.Row
Click to expand...
strPartNumUp = ActiveSheet.Cells(r, 1).Value
strPartNumDown = ActiveSheet.Cells(r + 1, 1).Value
Click to expand...

and many others.

Those should all be qualified with the appropriate object, probably
xlsApp. Otherwise, I believe VBA is going to create an implicit object
of its own to point to the Excel application, and that will keep it open
until your Access application closes and that implicit object is
destroyed.
 
You were 100% correct Dirk, I was being lazy and turned the references to
Excel in my Access DB. Took out that reference set and assigned all
variables to xlsApp. fixed the issue. Thanks...

Updated code...

xlsApp.ActiveWindow.Zoom = 85
'Delete AutoNumbers
xlsApp.Columns("A:A").Select
xlsApp.Selection.Delete Shift:=-4159
xlsApp.Range("A1").Select
xlsApp.Selection.End(-4121).Select
'Find end of file
End_Row = xlsApp.ActiveCell.Row

'r = 2 to skip header row
r = 2
Do Until r > End_Row
strPartNumUp = xlsApp.ActiveSheet.Cells(r, 1).Value
strPartNumDown = xlsApp.ActiveSheet.Cells(r + 1, 1).Value
 
Back
Top