AccessVba一件生成报表的代码

最新推荐文章于 2024-09-19 16:49:43 发布
原创最新推荐文章于 2024-09-19 16:49:43 发布 · 3k 阅读
3 ·
CC 4.0 BY-SA版权
001 Access VBA 专栏收录该内容
50 篇文章
订阅专栏
本文介绍了一种使用VBA实现从数据库导出数据并填充到Excel模板的方法，包括执行存储过程获取数据、导出到中间Excel文件及数据填充到模板的过程。
一键导出按钮的代码
Private Sub 打开PQ数量分析表_Click()
'    Dim EXL As Object
'    Dim strPath As String
'    strPath = "\\192.168.7.19\更新文件\报表\" & Me.生产部门 & Me.年份 & "年产品P-Q分析（数量）.xlsx"
'
'    If Len(Dir(strPath, vbDirectory)) > 0 Then
'        'MsgBox "文件" & CurrentProject.Path & "\报表\" & fileName & "已经存在"
'        Set EXL = CreateObject("Excel.Application")
'        'Set xlWbk = xlApp.Workbooks.Open(CurrentProject.Path & "\报表\" & wshName)
'        EXL.Workbooks.Open (strPath)
'        EXL.Visible = False
'        EXL.Visible = True
'    Else
'        MsgBox "报表不存在,请生成报表后再打开"
'    End If
'    'Debug.Print strPath
'    '没有密码时
'
'    '有密码时:
'    'EXL.Workbooks.Open "C:\Book.xls", , , , "打开密码","权限密码"



    Dim ord_path As String
    Dim fname As String
    Dim Folder As String
    Dim tbl_name As String
    Dim EXL As Object
    Dim wkb As Object
    Dim wkbbb As Object
    Dim rng As Object
    Dim rngbb As Object
    Dim rng_geshi As Object
    Dim Errnum As Integer
    Errnum = Err
    Dim bbpath As String
    Dim mbwsh_name As String
    Dim mb_path As String
    Dim file_type As String

    '-------------------------------------------------------------------------------------
    '一.发送命令给SQLserver,执行存储过程,准备好运算结果
    '-------------------------------------------------------------------------------------
    '执行报表存储过程
    EXEC_PROC_PQ分析 "proc_PQ分析数量", Me.年份, Me.生产部门

    '-------------------------------------------------------------------------------------
    '二.输出数据库数据表例如PQ分析(没有汇总的结果)到Excel中间表
    '-------------------------------------------------------------------------------------
    tbl_name = "PQ分析数量"'数据库中等待导出的原始表格,这里面存放着我的PQ分析底层数据
    fname = "表格导出"'那么PQ分析导出到哪里呢?导入到"表格导出.xlsx"
    Folder = "Excel输出文件夹"
    ord_path = CurrentProject.PATH & "\" & Folder & "\" & fname & ".xlsx"'这个表示最后的表格输出到"Excel输出文件夹\表格导出.xlsx"中中
    '上线都是在准备ExportToExcelQueryTables的3个传入参数.
    'ExportToExcelQueryTables的作用是复制表格到一个中间文件夹里面.

    ExportToExcelQueryTables tbl_name, Folder, fname



    If Len(Dir(ord_path, vbDirectory)) > 0 Then
'        On Error GoTo 创建:
        'MsgBox "文件" & CurrentProject.Path & "\报表\" & fileName & "已经存在"
'        Set EXL = GetObject(, "Excel.Application")
        Set EXL = CreateObject("Excel.Application")
        'Set xlWbk = xlApp.Workbooks.Open(CurrentProject.Path & "\报表\" & wshName)
        Set wkb = EXL.Workbooks.Open(ord_path)
        EXL.Visible = False
        EXL.Visible = True
    Else
        MsgBox "订单不存在,请生成后再打开"
    End If


    '-------------------------------------------------------------------------------------
    '三.准备模板表格
    '-------------------------------------------------------------------------------------
    '复制模板表格到本文件夹下
    bbpath = CurrentProject.PATH & "\报表"
    mbwsh_name = "产品P-Q分析（数量）"
    mb_path = "\\192.168.7.19\更新文件\报表模板"
    file_type = ".xlsx"
    copyFile bbpath, mb_path, mbwsh_name, file_type

    '打开等待输入数据的报表
    Set wkbbb = EXL.Workbooks.Open(bbpath & "\" & mbwsh_name & file_type)


    '-------------------------------------------------------------------------------------
    'excel表格的数据交换与格式设置
    '-------------------------------------------------------------------------------------
    '修改单元格里面的标题和名称
    wkbbb.Worksheets(mbwsh_name).Range("B2") = Me.生产部门 & "产品P-Q分析表（单位：张）"
    wkbbb.Worksheets(mbwsh_name).Range("B4") = Me.年份 & "年排名"
    wkbbb.Worksheets(mbwsh_name).Range("F4") = Me.年份 & "年"

    '开始进行数据交互
    Set rng = wkb.Worksheets(tbl_name).Range("a2")
    Set rngbb = wkbbb.Worksheets(mbwsh_name).Range("C8")
    '记录戒指行数
    used_row_count = wkb.Worksheets(tbl_name).UsedRange.rows.Count

    If (used_row_count < 2) Then

        wkbbb.Save
        wkb.Save
        Set wkbbb = Nothing
        Set wkk = Nothing
        EXL.Quit
        MsgBox "数据为空!无法生成报表!"
        Exit Sub
    End If

    rng.Resize(used_row_count - 1, 1).copy
    rngbb.pastespecial xlpastevalues '产品型号

    rng.OFFSET(0, 25).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 1).pastespecial xlpastevalues '产品系列

    rng.OFFSET(0, 1).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 8).pastespecial xlpastevalues '1月接单
    rng.OFFSET(0, 2).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 9).pastespecial xlpastevalues
    rng.OFFSET(0, 3).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 10).pastespecial xlpastevalues
    rng.OFFSET(0, 4).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 11).pastespecial xlpastevalues
    rng.OFFSET(0, 5).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 12).pastespecial xlpastevalues
    rng.OFFSET(0, 6).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 13).pastespecial xlpastevalues
    rng.OFFSET(0, 7).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 14).pastespecial xlpastevalues
    rng.OFFSET(0, 8).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 15).pastespecial xlpastevalues
    rng.OFFSET(0, 9).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 16).pastespecial xlpastevalues
    rng.OFFSET(0, 10).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 17).pastespecial xlpastevalues
    rng.OFFSET(0, 11).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 18).pastespecial xlpastevalues
    rng.OFFSET(0, 12).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 19).pastespecial xlpastevalues
    rng.OFFSET(0, 13).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 20).pastespecial xlpastevalues
    rng.OFFSET(0, 14).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 21).pastespecial xlpastevalues
    rng.OFFSET(0, 15).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 22).pastespecial xlpastevalues
    rng.OFFSET(0, 16).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 23).pastespecial xlpastevalues
    rng.OFFSET(0, 17).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 24).pastespecial xlpastevalues
    rng.OFFSET(0, 18).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 25).pastespecial xlpastevalues
    rng.OFFSET(0, 19).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 26).pastespecial xlpastevalues
    rng.OFFSET(0, 20).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 27).pastespecial xlpastevalues
    rng.OFFSET(0, 21).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 28).pastespecial xlpastevalues
    rng.OFFSET(0, 22).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 29).pastespecial xlpastevalues
    rng.OFFSET(0, 23).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 30).pastespecial xlpastevalues
    rng.OFFSET(0, 24).Resize(used_row_count - 1, 1).copy
    rngbb.OFFSET(0, 31).pastespecial xlpastevalues

    '-------------------------------------------------------------------------------------
    '设置删除的开始行
    '-------------------------------------------------------------------------------------

    'leftTop_char       左上角的行号,例如:B
    'leftTop_int        左上角的行号,例如:8
    'rightBottom_char   右下角的行号,例如:X
    'rightBottom_int    右下角的行号,例如:used_row_count+leftTop_int
    leftTop_char = "B"
    leftTop_int = 7
    rightBottom_char = "AH"
    rightBottom_int = used_row_count + leftTop_int
    Set rng = wkbbb.Worksheets(mbwsh_name).Range("a" & rightBottom_int).rows("1:1")
    Set rng = rng.Resize(3000, 50)
    rng.Delete Shift:=xlUp

    wkbbb.Save
    wkb.Save

ExitHere:
    '这里关掉一些中间的对象,比方说recordset等
    '但是展现在客户面前的东西不能关闭,
    '最好以显性的方式展现出来
    '这样客户也好关闭
'    wkb.Save
'    wkb.Close
    MsgBox "成功啦"
    Exit Sub

创建:
    If Err = 429 Then
        Set EXL = CreateObject("Excel.Application")
        Resume Next
    Else
        If (Errnum = Err) Then Exit Sub
        MsgBox "错误编号：" & Err.Number & vbCrLf & "错误描述：" _
        & Err.Description, , "您出错了！"
        Errnum = Err
        Resume ExitHere
    End If
End Sub