Exporting Problem

[azizrasul]

I have the following code in a module.

Public Function Excel_Export(strFileName As String)

Dim dbs As Database
Dim strMessage As String
Dim intX As Integer
Dim strSQL As String
Dim xlApp As Excel.Application
Dim xlBook_S As Excel.Workbook, xlBook_F As Excel.Workbook
Dim xlSheet_S As Excel.Worksheet, xlSheet_F As Excel.Worksheet
Dim intColumnCountS As Integer, intColumnCountF As Integer
Dim lngRowCountS As Long, lngRowCountF As Long
Dim objXL As Object
Dim objActiveWkb As Excel.Workbook

Set dbs = CurrentDb

'~~~Supplied by contributor on this site~~~
On Error Resume Next
Set objXL = GetObject(, "Excel.Application")

'What did we find?...
If Not TypeName(objXL) = "Empty" Then
strMessage = "Excel Running."
Set objActiveWkb = objXL.Application.ActiveWorkbook
objXL.Visible = True
objActiveWkb.Close
objXL.Application.Quit
Set objActiveWkb = Nothing
Set objXL = Nothing
Else
strMessage = "Excel Not Running."
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Set xlApp = CreateObject("Excel.Application")
Set xlBook_S = xlApp.Workbooks.Open(strFileName, ReadOnly:=False)
Set xlSheet_S = xlBook_S.Worksheets(1)

xlApp.Workbooks(1).Activate 'This is better as you can specify the workbook.
xlApp.Visible = True 'Makes the MS Excel application visible.

intColumnCountS = xlSheet_S.UsedRange.Columns.Count
lngRowCountS = xlSheet_S.UsedRange.Rows.Count

For intX = 1 To intColumnCountS
xlBook_S.Worksheets(1).Columns(intX).AutoFit
Next

With xlApp
.Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.Columns("AQ:AQ").Select
.Selection.Font.ColorIndex = 3
.Range("A1").Select
End With

xlApp.DisplayAlerts = False
xlBook_S.SaveAs strFileName
xlBook_S.Close SaveChanges:=True

xlApp.Application.Quit
Set xlSheet_S = Nothing
Set xlBook_S = Nothing
Set xlApp = Nothing

End Function

If I leave the bit of code within the ~~~~~ section, the With ... End With section does not work. If I delete the ~~~~~ section, the With... End With section does work but each alternative occasion i.e. the Excel application iremains open in the background and I have to delete from the task manager.

Can anyone to resolve this for me.

 

[bat17]

Here is the basic template I use when working with XL. Not sure how much it will help though.

Sub updateXl()
Dim xlApp As Excel.Application
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim qrySetUp As Excel.QueryTable

On Error GoTo ErrorHandler

Set xlApp = GetObject(, "Excel.Application")
Set xlBook = xlApp.Workbooks.Open(strOpenMasterPath)

 ' Do things here

xlApp.Application.Visible = True

ErrorHandlerExit:
   Set rst = Nothing
   Set dbs = Nothing
   Set qrySetUp = Nothing
   Set xlBook = Nothing
   Set xlApp = Nothing
   Exit Sub

ErrorHandler:
   If Err = 429 Then
'Excel is not running; open Excel with CreateObject
      Set xlApp = CreateObject("Excel.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
End Sub

Peter

 

[azizrasul]

I have tied your code, but can't get it to work.

I get an error in the Error Handler section of code which says:-

Error No: 462; Description: The remote server machine does not exist or is unavailable. this error appears when the With...End With section of my code comes into play.

 

[Ian Mac]

Your:

With xlApp
.Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.Columns("AQ:AQ").Select
.Selection.Font.ColorIndex = 3
.Range("A1").Select
End With

might work with:

With xlApp.
.Selection.Sort Key1:=xlApp.Application.[Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.Columns("AQ:AQ").Select
.Selection.Font.ColorIndex = 3
.Range("A1").Select
End With

Or some such similar, I haven't tested the above but take a look at:
http://www.mrexcel.com/board2/viewtopic.php?t=20520&postdays=0&postorder=asc&start=0

I had the same problem.

Hope this works.

 

[azizrasul]

Thanks Ian. That worked. Your a genius.