AccessVba⼀件⽣成报表的代码
⼀键导出按钮的代码
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)) > 0Then
'        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表格的数据交换与格式设置
access数据库生成网页版
'-------------------------------------------------------------------------------------
'修改单元格⾥⾯的标题和名称
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).ws.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 = 429Then
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

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。