Exporting Data to Excel, but process not finishing 3

[nic6000]

Hi,

I wonder is someone can help me?

Basically I have some VBA which exports a recordset to Excel and then formats the cells - the Excel application then stays open so the user can view the data. This all works fine until I come to run the code again, which susequently doesnt always run after closing down the Excel App.

It seems that the original process hasn't finished and I have to go into Task Manager every time to close it within 'Processes'.

I am using Access 2000 and Excel v9

Is there a sure way to kill the process each time? I have added my code below: -

DoCmd.Hourglass True
On Error GoTo errhndl1

strQueryPt1 = Me.cboQuery.Column(1) & Me.cboQuery.Column(2) & Me.cboQuery.Column(3)
strQueryPt2 = Me.cboFieldName.Column(2)
strQueryPt3 = Me.cboFieldName.Column(0)
strQueryPt4 = Me.cboFieldName.Column(3)
strQueryPt5 = Me.cboSearchType.Column(1)
datatype = Me.txtValue.Value

If strQueryPt4 = "text" Then
strQueryPt6 = "'" & datatype & "'"
Else
strQueryPt6 = "#" & MakeUsDate(datatype) & "#"
End If

strQueryAll = strQueryPt1 & " WHERE [" & strQueryPt2 & "]![" & strQueryPt3 & "] " & strQueryPt5 & " " & strQueryPt6


'''''export query results to new excel file

Set objXL = New Excel.Application
Set objWkb = Excel.Workbooks.Add 'Create New Excel Workboox
Set db = CurrentDb
Set rst = db.OpenRecordset(strQueryAll)

With objXL
Set objSht = objWkb.Worksheets("Sheet1")
objSht.Select


objSht.Cells.Select
excelborders

iNumCols = rst.Fields.Count 'Add recordset field headings to worksheet
For i = 1 To iNumCols
objSht.Cells(1, i).Value = rst.Fields(i - 1).Name
Next
objSht.Range("A2").CopyFromRecordset rst 'add recordset
End With

rst.Close

c = 1
Do Until Cells(1, c) = ""
excelheaders
c = c + 1
Loop

objSht.Cells.Select
objSht.Cells.EntireColumn.AutoFit

With objXL
.Visible = True
End With

exitsub:

Set objSht = Nothing
Set objWkb = Nothing
Set objXL = Nothing
Set rst = Nothing
Set db = Nothing
DoCmd.Hourglass False

Exit Sub

errhndl1:

MsgBox "An error has occurred, please contact the database administrator", vbExclamation

Resume exitsub


Ps I don't want the file saved in the VBA, I want the user to have a choice of either saving the file or quitting without saving it.

 

[JerryKlmns]

Change this

Set objWkb = Excel.Workbooks.Add

to

Set objWkb = objXL.Workbooks.Add

 

[nic6000]

Hi,

Thanks very much for that, its seems to have done the trick except the formatting no longer works. The code finishes whihout error, but the excel spreadsheet isnt formatted - any ideas?

Thanks,

NIc

 

[JerryKlmns]

I've missed that
Do Until Cells(1, c) = ""

Do Until objSht.Cells(1, c) = ""

The general idea is to explicitly reference objects especialy for excel.

 

[nic6000]

Hi,

I get you about the excplit ref - thats cool, but still no joy;

The code reads

c = 1
Do Until objSht.Cells(1, c) = ""
excelheaders
c = c + 1
Loop

With Sub 'exceheaders' looking like.....

objSht.Cells(1, c).Select

Selection.Font.Bold = True
With Selection.borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
With Selection.borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
With Selection.borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
With Selection.borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
With Selection.Interior
.ColorIndex = 19
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

End Sub

Any ideas

Thanks,

Nic

 

[PHV]

Replace ALL occurrences of Selection with objXL.Selection

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[JerryKlmns]

Nic

I think that it would be better to

Dim myRange As Excel.Range

Set myRange = objSht.Cells(1, c)
myRange.Font.Bold = True
    With myRange.borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 1
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 1
    End With
    With myRange.borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 1
    End With
    With myRange.borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 1
    End With
    With myRange.borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 1
    End With
    With myRange.Interior
        .ColorIndex = 19
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
Set myRange = Nothing

But I could be wrong and some fine flavor crayon draw us a better picture

 

[nic6000]

Fantastic, thanks guys both ways work fine!