Question

我使用以下代码将访问数据导出到excel。我需要格式化excel表，这就是我使用以下代码的原因。问题是，当我执行代码时，它打开了一个名为book1的电子表格。我想将它直接保存到文件夹路径。我该怎么做？

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

Answer 1

姓名＆＃34; Book1＆＃34;是新工作簿的默认名称，它在内存中，而不是在磁盘上。保存工作簿，名称将被更改：

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

导出并将Access xlSheet保存到Excel

1 个答案: