CODEWITHSUNDEEP
ms-accessvba
Devil's Dream
Devil's Dream

Reputation: 715

Export and save Access xlSheet to Excel

I am using the following code to export access data to excel. I need formatted excel sheet, this is why I am using the following code. The problem is when I am executing the code its opening a spreadsheet named book1. I want to save it directly to a folder path. How Can I do this?

Private Sub cmdTransfer_Click()
On Error GoTo SubError

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim SQL As String
Dim rs1 As DAO.Recordset
Dim i As Integer
Dim j As Integer

'Show user work is being performed
DoCmd.Hourglass (True)

'*********************************************
'              RETRIEVE DATA
'*********************************************
Dim regArray

regArray = Array("One", "Two", "Three")

For j = 0 To UBound(regArray)
Dim regName As String
regName = regArray(j)
'MsgBox regName
'SQL statement to retrieve data from database
SQL = "SELECT PartNo, PartName, Price, SalePrice, " & _
"(Price - SalePrice) / Price AS Discount " & _
"FROM Parts " & _
"ORDER BY PartNo WHERE PartNo =('" & regName & "');"

'Execute query and populate recordset
Set rs1 = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)

'If no data, don't bother opening Excel, just quit
If rs1.RecordCount = 0 Then
    MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
    GoTo SubExit
End If

'*********************************************
'             BUILD SPREADSHEET
'*********************************************
'Create an instance of Excel and start building a spreadsheet

'Early Binding
Set xlApp = Excel.Application

xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

With xlSheet
    .Name = "Discount"
    .Cells.Font.Name = "Calibri"
    .Cells.Font.Size = 11

    'Set column widths
    .Columns("A").ColumnWidth = 13
    .Columns("B").ColumnWidth = 25
    .Columns("C").ColumnWidth = 10
    .Columns("D").ColumnWidth = 10
    .Columns("F").ColumnWidth = 10


    For cols = 0 To rs1.Fields.Count - 1
        .Cells(1, cols + 1).Value = rs1.Fields(cols).Name
    Next

    'Copy data from recordset to sheet
    .Range("A2").CopyFromRecordset rs1

End With

xlBook.SaveAs "E:\new\Report_" & regName & ".xlsx"

Next


SubExit:
On Error Resume Next
    DoCmd.Hourglass False
    'xlApp.Visible = True
    rs1.Close
    Set rs1 = Nothing
    Exit Sub

SubError:
    MsgBox "Error Number: " & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, _
        "An error occurred"
    GoTo SubExit
    End Sub

Upvotes: 0

Views: 627

Answers (1)

Sergey S.
Sergey S.

Reputation: 6336

Name "Book1" is default name for new workbook, it is in memory, not on disk.Save the workbook, name will be changed:

xlBook.SaveAs "C:\path\MyFile.xls"

Upvotes: 1

Related Questions