参考以下代码，自己修改：
On Error GoTo Err_cmdExportToExcel_Click
Dim strTemplate As String '模板文件路径名
Dim strPathName As String '输出文件路径名
Dim objApp As Object 'Excel程序
Dim objBook As Object 'Excel工作簿
Dim rst As Object '子窗体记录集
Dim intN As Integer '循环计数器
Dim blnNoQuit As Boolean '此标记为True时不关闭Excel
Dim strSQL As String
Dim cnn As Object 'ADODB.Connection
'当前是新记录则提示并退出
If Me.NewRecord Then
MsgBox "当前没有数据可导出！", vbExclamation, "提示"
Exit Sub
End If
'模板文件路径
strTemplate = CurrentProject.Path + "\Template\合同评审单.xlt"
'默认保存的文件名
strPathName = CurrentProject.Path & "\Report\" & Me.销售订单号 & ".xlsx"
'通过文件对话框取得另存为文件名
'With FileDialog(2) 'msoFileDialogSaveAs
'.InitialFileName = strPathName
'If .Show Then
'strPathName = .SelectedItems(1)
'Else
'Exit Sub
'End If
'End With
'如果文件名后没有.xls扩展名则加上
If Not strPathName Like "*.xlsx" Then strPathName = strPathName & ".xlsx"
'删除已有文件
If Dir(strPathName) <> "" Then Kill strPathName
'设置鼠标指针为沙漏形状
DoCmd.Hourglass True
'创建Excel对象
Set objApp = CreateObject("Excel.Application")
'打开模板文件
Set objBook = objApp.Workbooks.Open(strTemplate)
objBook.Sheets("合同评审单").Select
With objApp
Set cnn = CurrentProject.Connection
'根据主窗体记录写入订单表头及表尾等固定位置的信息，注意表尾必须先写入，
strSQL = "Select * From [Qrpt销售订单表] Where [销售订单号]='" & Me.销售订单号 & "'"
Set rst = OpenADORecordset(strSQL, , cnn)
.Range("C2") = rst!经办人
.Range("F2") = rst!客户代码
rst.Close
'写入明细表的信息
strSQL = "SELECT * From [Qrpt销售订单明细表] Where [销售订单号]='" & Me.销售订单号 & "'"
Set rst = OpenADORecordset(strSQL, , cnn)
intN = 15
Do Until rst.EOF
intN = intN + 1
.Range("C" & intN) = rst!物料名称
.Range("H" & intN) = rst!规格型号
.Range("J" & intN) = rst!单价
.Range("O" & intN) = rst!数量
.Range("P" & intN) = rst!单位
.Range("Q" & intN) = rst!金额
rst.MoveNext
Loop
rst.Close
End With
'保存Excel文件，因为模板是不能修改的，所以是另存为
objBook.SaveAs strPathName
Beep
'If MsgBox("导出已完成，是否打开导出的Excel文件？", vbQuestion + vbYesNo, "导出完成") = vbYes Then
objApp.Visible = True
objBook.Saved = True
blnNoQuit = True
'自动进入打印预览
objApp.ActiveWindow.SelectedSheets.PrintPreview
'End If
Exit_cmdExportToExcel_Click:
On Error Resume Next
If Not blnNoQuit Then
If Not objBook Is Nothing Then
objBook.Saved = True
objApp.Quit
End If
End If
'恢复鼠标指针
DoCmd.Hourglass False
'释放对象变量内存
Set objApp = Nothing
Set objBook = Nothing
Set rst = Nothing
Set cnn = Nothing
Exit Sub
Err_cmdExportToExcel_Click: '错误处理程序
If Err = 70 Then
MsgBox "不能替换文件，因为无法删除已有文件，可能的原因有：" & vbCrLf & vbCrLf & _
"1.该文件处于打开状态。" & vbCrLf & _
"2.没有对此目录的写入权限。", vbCritical, "错误 #70"
Else
MsgBox Err.Description, vbCritical, "错误 #" & Err
End If
Resume Exit_cmdExportToExcel_Click
