设为首页收藏本站Access中国

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

返回列表 发新帖
查看: 5689|回复: 3
打印 上一主题 下一主题

[窗体] ACCESS导出到EXCEL时提示下标越界

[复制链接]
跳转到指定楼层
1#
发表于 2019-5-18 10:53:28 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
Private Sub Command119_Click()

    '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 strPicPath As String            '图片路径
    Dim strPic  As String               '
    '当前是新记录则提示并退出
    If Me.NewRecord Then
        MsgBox "当前没有数据可导出!", vbExclamation, "提示"
        Exit Sub
    End If
If 汇总 = "按照工程汇总" Then
    '模板文件路径
    strTemplate = CurrentProject.Path & "\项目材料统计.xltm"
    '图片文件夹路径
   ' strPicPath = CurrentProject.Path & "\产品图片\"
    '默认保存的文件名
    strPathName = CurrentProject.Path & "D:\ " & Me.汇总.Column(1) & " " & Format(Date, "YYYY-MM-DD") & ".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  '这个地方提示下标越界
    With objApp
        Set rst = Me.Child132.Form.Recordset
        If rst.RecordCount > 0 Then rst.MoveLast
        intN = 4
        Do Until rst.BOF
            intN = intN + 1
            '不是第一行明细时插入一行
            If intN > 10 Then
                .Rows("10:10").Select
                objApp.Selection.Insert -4122, 1 'xlShiftDown=-4122,xlFormatFromRightOrBelow=1
            End If
            '写入订单明细
            .Range("B5") = Me.Child132!工程
            .Range("D5") = rst!开始日期
            .Range("E5") = rst!结束日期
            .Range("F5") = rst!总计金额
            rst.MovePrevious
        Loop
        '由于通过插入的方式添加明细行时,合并单元格被取消,所以需要通过复制格式
        '的方式设置一下
        .Range("A" & intN, "F" & intN).Copy
        .Range("A5", "F" & intN - 1).PasteSpecial -4122 'xlPasteFormats
        '在订单明细最后写入总计
        .Range("D" & intN + 1) = "金额总计:"
        .Range("E" & intN + 1).Formula = "=SUM(E5:F" & intN & ")"
        .Range("A1").Select
    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
    Exit Sub









ElseIf 汇总 = "按照班组汇总" Then




End If




End Sub
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏 分享分享 分享淘帖 订阅订阅
推荐
发表于 2019-5-18 17:51:37 | 只看该作者
herry2003aa 发表于 2019-5-18 10:53
objBook.Sheets("工程材料金额").Select  '这个地方提示下标越界

是不是没有这个工作表?
回复 支持 1 反对 0

使用道具 举报

2#
 楼主| 发表于 2019-5-18 10:53:46 | 只看该作者
objBook.Sheets("工程材料金额").Select  '这个地方提示下标越界
4#
 楼主| 发表于 2019-5-20 15:26:43 | 只看该作者
roych 发表于 2019-5-18 17:51
是不是没有这个工作表?

后来我也发现了,犯了低级错误。
您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-11-14 13:05 , Processed in 0.095697 second(s), 28 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表