1.作用
有时候为了导出数据到指定的excel里，excel格式为固定，直接导出表格式往往不能满足条件，结合前辈代码略作修改实现必要功能。
2.代码实现
Private Sub Command38_Click()
On Error GoTo ErrorHandler
Dim strTemplate As String '模板文件路径名
Dim strPathName As String '输出文件路径名
Dim objApp As Object 'Excel程序
Dim objBook As Object 'Excel工作簿
Dim rst As Object '子窗体记录集
Dim intRows As Integer '明细记录行数
Dim intCounter As Integer '循环计数器
Dim blnNoQuit As Boolean '此标记为True时不关闭Excel
Dim strMsg As String '消息内容
'当前是新记录则提示并退出（仅用于主子窗体时）
If Me.NewRecord Then
MsgBox "当前没有数据可导出！", vbExclamation, "提示"
Exit Sub
End If
'模板文件路径
strTemplate = CurrentProject.Path & "\LTE天馈调整工单.xltx"
'默认保存的文件名
' strPathName = CurrentProject.Path & "\订单 " & Me.客户ID.Column(1) & " " & Me.订单ID & ".xls"
' strPathName = "网格10LTE天馈调整工单" & "(" & Date & ")" & ".xlsx"
strPathName = "网格10LTE天馈调整工单" & "(" & Format(Date, "MM月DD日") & ")" & ".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 "*.xls" Then strPathName = strPathName & ".xlsx"
If Dir(strPathName) <> "" Then Kill strPathName '删除已有文件
'创建Excel对象
Set objApp = CreateObject("Excel.Application")
'打开模板文件
Set objBook = objApp.Workbooks.Open(strTemplate)
'选中模板所在的工作表（防止模板不是活动工作表）
objBook.Sheets("sheet1").Select
'写入订单明细
Set rst = Me.frmchild.Form.Recordset
'如果明细行数不为0，移到最后一行
If rst.RecordCount <> 0 Then rst.MoveLast
'将明细的最大行数保存到变量
intRows = rst.AbsolutePosition + 1
Do Until rst.BOF
'选中第10行（即设置好格式的明细行）
objApp.Rows("2:2").Select
objApp.CutCopyMode = False
'复制该行
objApp.Selection.Copy
'以插入的方式粘贴
objApp.Selection.Insert Shift:=-4121 'xlDown
objApp.Range("A3") = "网格10"
objApp.Range("B3") = "龙湾"
objApp.Range("C3") = Mid(rst!站名, 2, 6)
objApp.Range("D3") = rst!站名
objApp.Range("E3") = rst!小区号
objApp.Range("F3") = rst!派单原因
objApp.Range("G3") = rst!需调整
objApp.Range("H3") = rst!调整后数值
objApp.Range("I3") = rst!联系人
objApp.Range("J3") = rst!电话
objApp.Range("K3") = rst!备注
objApp.Range("L3") = Date
rst.MovePrevious
Loop
'因为第2行只是用于复制格式用的空行，所以这里要将它删除掉
objApp.Rows("2:2").Select
objApp.Selection.Delete Shift:=-4162 'xlUp
objApp.Range("A1").Select
'保存Excel文件，因为模板是不能修改的，所以是另存为
objBook.SaveAs strPathName
Beep
strMsg = "导出已完成，是否打开导出的Excel文件？"
If MsgBox(strMsg, vbQuestion + vbYesNo, "导出完成") = vbYes Then
objApp.Visible = True
objBook.Saved = True
blnNoQuit = True
End If
Done:
'防止因出错时Excel没有正确关闭（可能处于隐藏状态）
On Error Resume Next
If Not blnNoQuit Then
objBook.Saved = True
objApp.Quit
End If
Set objApp = Nothing
Set objBook = Nothing
Set rst = Nothing
Exit Sub
ErrorHandler: '错误处理程序
If Err = 70 Then
strMsg = "不能替换文件，因为无法删除已有文件，可能的原因有：" & vbCrLf & vbCrLf & _
"1.该文件处于打开状态。" & vbCrLf & _
"2.没有对此目录的写入权限。"
Else
strMsg = Err.Description
End If
strMsg = "错误号：" & Err & vbCrLf & _
"错误源：" & Err.Source & vbCrLf & _
"错误描述：" & strMsg
MsgBox strMsg, vbCritical, "出错"
Resume Done
End Sub
