我做了一个ACCESS导出数据到EXCEL模板的例子，但是现在系统提示有错误，请帮助看看...

yanwei82123300

大家好!我做了一个ACCESS导出数据到EXCEL模板的例子，但是现在系统提示有错误，请帮助看看，谢谢
需要引用EXCEL

更新了附件

yanwei82123300

附件是模板！

huangli0356

Private Sub 导出_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 strPicPath  As String   '图片路径
    Dim strPicName  As String   '图片名称
    Dim strmsg      As String   '消息内容
   
    '当前是新记录则提示并退出（仅用于主子窗体时）
    If Me.NewRecord Then
        MsgBox "当前没有数据可导出！", vbExclamation, "提示"
        Exit Sub
    End If

    '模板文件路径
    strTemplate = CurrentProject.Path & "\Bin\采购模板.xlt"
    '图片文件夹路径
    strPicPath = CurrentProject.Path & "\产品图片\"
    '默认保存的文件名
    strPathName = CurrentProject.Path & "\订单\ " & Me.厂商代码 & " " & Me.单号 & ".xls"

    '通过文件对话框取得另存为文件名
    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 & ".xls"
    If Dir(strPathName) <> "" Then Kill strPathName    '删除已有文件
    '设置鼠标指针为沙漏形状
    DoCmd.Hourglass True
    '创建Excel对象
    Set objApp = CreateObject("Excel.Application")
    '打开模板文件
    Set objBook = objApp.Workbooks.Open(strTemplate)
    '选中模板所在的工作表（防止模板不是活动工作表）
    objBook.Sheets("采购订单").Select
    '根据主窗体记录写入订单表头及表尾等固定位置的信息，注意表尾必须先写入，
    '然后再写入明细，否则无法正确定位表尾的数据项
    objApp.Range("C4") = Me.厂商代码
    '组合框第1列只是客户ID，第2列才是客户名称，下同
    objApp.Range("C5") = Me.厂家
    objApp.Range("C6") = Me.联系人
    objApp.Range("C7") = Me.Tel
    objApp.Range("C8") = Me.Fax
    objApp.Range("C9") = Me.送货地址
'    objApp.Range("H2") = Me.雇员ID.Column(1)
    objApp.Range("G4") = Me.单号
    objApp.Range("G5") = Me.日期
    objApp.Range("G6") = Me.送货联系人
    objApp.Range("G7") = Me.送货Tel
    objApp.Range("G8") = Me.送货Fax

    '收货信息（表尾）
    objApp.Range("A17") = Me.特别提醒
    objApp.Range("A18") = Me.注意事项
'    objApp.Range("C15") = Me.货主地址

    '写入订单明细
    Set rst = Me.材料订购明细.Form.Recordset
    '如果明细行数不为0，移到最后一行
    If rst.RecordCount <> 0 Then rst.MoveLast
    '将明细的最大行数保存到变量
    intRows = rst.AbsolutePosition + 1
    Do Until rst.BOF
        '选中第14行（即设置好格式的明细行）
        objApp.Rows("14:14").Select
        objApp.CutCopyMode = False
        '复制该行
        objApp.Selection.copy
        '以插入的方式粘贴
        objApp.Selection.Insert Shift:=-4121   'xlDown
        objApp.Range("A15") = rst.AbsolutePosition + 1
        objApp.Range("A15") = Me.材料订购明细!品名    '.Column(1)
        objApp.Range("B15") = rst!规格
        objApp.Range("D15") = rst!数量
        objApp.Range("E15") = rst!单价
        objApp.Range("G15") = rst!交期
        objApp.Range("H15") = rst!备注
        
        objApp.Range("F15") = CCur(rst!单价 * rst!数量)

'        strPicName = strPicPath & rst!产品ID & ".jpg"
        '如果该产品有图片，则插入图片
'        If Dir(strPicName) <> "" Then
'            objApp.Range("H11").Select
'            objApp.ActiveSheet.Pictures.Insert(strPicName).Select
            '调整图片位置
'            objApp.Selection.ShapeRange.IncrementLeft 2
'            objApp.Selection.ShapeRange.IncrementTop 2
            '调整图片大小,注意必需要取消纵横比锁定，不然大小会有问题
'            objApp.Selection.ShapeRange.LockAspectRatio = 0
'            objApp.Selection.ShapeRange.width = 112
'            objApp.Selection.ShapeRange.height = 85
'       End If
        rst.MovePrevious
    Loop
    '因为第14行只是用于复制格式用的空行，所以这里要将它删除掉
    objApp.Rows("14:14").Select
    objApp.Selection.Delete Shift:=-4162   'xlUp
    '在一个不用的临时单元格进行金额汇总
    objApp.Range("P1").Formula = "=SUM(F14:F" & 13 + intRows & ")"
    '将汇总后的金额值写入金额列最后一行之后
'    objApp.Range("A" & 14 + intRows) = "合计货款金额：" & format(objApp.Range("P1"), "Currency")
    objApp.Range("A" & 14 + intRows) = "合计货款金额：" & Dxje(format(objApp.Range("P1"), "Currency"), 1)
    '="人民币" & dxje([总金额],1)
    '清空临时单元格
    objApp.Range("P1").Formula = ""
    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
        '自动进入打印预览
        'objApp.ActiveWindow.SelectedSheets.PrintPreview
    End If

Done:
    '防止因出错时Excel没有正确关闭（可能处于隐藏状态）
    On Error Resume Next
    If Not blnNoQuit Then
        objBook.Saved = True
        objApp.Quit
    End If
    '恢复鼠标指针
    DoCmd.Hourglass False
    '释放对象变量内存
    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


可参考下我现在在用的.跟你的差不多..呵呵..

yanwei82123300

你好能给个例子吗？

yanwei82123300

大家好！我的例子已经修改完成了，可以顺利导出数据现在想将EXCEL的"F列"进行求和，请大家看看如何才能使用代码进行求和，并且在“E列添加个名称”“总计”，请大家给看看，谢谢

miracle-y

学习一下

koutx

yanwei82123300 发表于 2012-12-21 21:47
大家好！我的例子已经修改完成了，可以顺利导出数据现在想将EXCEL的"F列"进行求和，请大家看看如何才能使用 ...

F列求和：在Next i 下加两行：
Next i
        xlsSheet.Cells(Rst1.RecordCount + 11, 6) = "=SUM(F11:F" & Rst1.RecordCount + 10 & ")"
End If

yanwei82123300

koutx老师，谢谢帮助，请问我想在E列 加个名称“合计”，如何做到，谢谢

yanwei82123300

会了：xlsSheet.Cells(Rst1.RecordCount + 11, 5) = "合计"