Access交流网
  • 设为首页|收藏本站|繁体中文|手机版
  •     
  • Access培训-Access开发平台-Access行业开发

  • 首页
  • 资讯
  • 技巧
  • 源码
  • 行业
  • 资源
  • 产品
  • 活动
  • 培训
  • 招聘
  • 论坛
  • 商城
  • 关于

培训

Access企业培训(现场)
Access在线培训

Access中级培训

Access高级培训

Access定制培训

Access树控件与BOM高级技巧

Access公开课
Access免费公开课视频
Access培训(VIP)
Access培训优惠信息

热门文章

  • Access动画式关闭窗体..
  • access图片分页展示及..
  • Access通用TAB键和..
  • 能排序的列表框-Acces..
  • Access调用网页功能-..
  • Access调用网页功能-..

最新文章

  • Access自动播音员-A..
  • Access智能搜索组合框..
  • Access自动执行宏的妙..
  • access图片分页展示及..
  • 通用读取文本文件模块-Ac..
  • Access通用TAB键和..

联系方式

Access交流网

电  话:0760-88315075
热  线:0760-88315075

邮  编:528463
咨询QQ:1918333016
营销QQ:4008553990

Email:1918333016@qq.com

网  址:www.access-cn.com

当前位置:首页 > 培训 > Access培训(VIP)
Access培训(VIP)

数据自动导出多个Excel或者多个工作表-Access经典源码剖析

 
Access主题 主题:Access数据自动导出多个Excel或者工作表-高手之路                  听课人数:70多人      
Access主讲 主讲:王宇虹        演讲时间:2014-11-26 15:30 至 2014-11-26 16:30 and  2014-12-03 15:30 至 2014-12-03 16:30
Access培训内容 讲课内容简介:                   Access培训报名: http://www.office-cn.net/thread-118946-1-1.html
  讲解excel与Access的交互内容,通过操作access,可以非常方便地实现access操作excel表格,可以快速导入导出excel数据。同时对excel批量统计生成报表打印。生成大量的邮寄标签寄发给用户
 培训优势:使用新版Access2013+思维导图模式+Access源码剖析+在线课堂+PPT课件  培训
 培训目标:让你 听得懂 学得会 记得住 用得上             要求:有一定的Access 或 VBA的基础 
 

 

clip0058

Access数据自动导出多个Excel或者工作表


 

 

application_key 功能描述:

 

  • 自动批量生成excel报表

  • 自动汇总统计表格信息

  • 自动导出到excel

  • 同时导出到汇总列表

  • 导出到工作表

 

 

application_key  行业应用场景:

 
  • 自动生成EXCEL报表

  • 生在大量的邮寄标签

  • 批量生成报表发送给客户

 
application_key  界面预览:

    access数据库

     access数据库

     

     access数据库

 

application_key  源码思维导图(脑图):

 

     access数据库

 

Access教程视频Access数据自动导出多个Excel或者工作表 -- Access经典源码剖析思维导图在线播放

可直接展开和收缩思维导图中的每个节点来浏览,也可使用下面的放大 缩小 折叠 定位焦点 全页显示 查找关键字等功能
 

 

 

application_key  Access培训笔记:

 

  经典源码剖析系列 数据自动导出多个EXCEL或多个工作表 Office中国-王宇虹

1 应用场景

1.1 自动生成EXCEL报表

1.2 生在大量的邮寄标签

1.3 批量生成报表发送给客户

2 模块 源码剖析

2.1 导出格式模板文件

2.1.1 Tpl.xlt

2.2 模板文件不存在,请先确保模板文件是否被误删除了

2.3 导出前先清空目标目录

2.3.1 Output

2.3.1.1 输出目录不存在,请先手工创建

2.3.2 正在清空目标文件夹的旧xls文件

2.3.2.1 循环所有文件

2.3.2.2 如果存在则删除

2.3.2.2.1 Kill CurrentProject.Path & "\Output\" & strFile

2.3.2.2.2 如果被删除的文件正在被打开

2.3.2.2.2.1 Err.Number = 70

2.3.2.2.2.2 你可能正在打开Output目录下生成的EXCEL文件或其它Excel文件

2.4 打开excel对象

2.4.1 是否显示出来

2.4.1.1 If FShowExcelApp.Value <> 0 Then       objExl.Visible = True    End If

2.4.2 禁止EXCEL弹出警告信息

2.4.2.1 objExl.DisplayAlerts = False

2.4.3 如果EXCEL对象未打开,就先创建

2.4.3.1 CreateObject("Excel.APPLICATION")

2.5 把汇总的数据逐条写入到excel

2.5.1 打开源数据集

2.5.1.1 rsTotal.Open "select * from tblTotal order by FMark Desc,FID"

2.5.2 处理方式

2.5.2.1 FMultiXlsFiles

2.5.2.1.1 多个EXCEL文件

2.5.2.1.1.1 \Output\File" & lngFileNo & ".xls

File1

File2

File3

File4

2.5.2.1.2 一个EXCEL文件,多工作表

2.5.2.1.2.1 Output\FileAll.xls

2.5.3 判断是否达到20条

2.5.3.1 If lngSeqNo Mod 20 = 0

2.5.3.1.1 取余数

2.5.3.2 1.产生一个新的XLS文件

2.5.3.3 2.创建一个新的工作表

2.5.3.3.1 复制模板格式到第2个工作表

2.5.3.3.2 改名 报关单1

2.5.4 一直循环到处理完所有的数据

2.5.5 如果是多XLS文件 方式,把当前的XLS关闭

2.6 在界面上显示处理的进度

2.6.1 友好性

2.7 提示生成完成,是否打开目标文件夹

2.7.1 用户体验

2.8 在界面上显示处理完毕

2.9 打扫现场

2.9.1 对象关闭

2.9.1.1 把整个EXCEL文件及对象关闭

2.9.1.1.1 不关闭,对象 内存没有释放

2.9.2 释放内存

2.9.3 原来的设置要还原

2.9.3.1 打开警告信息显示开关

2.9.3.1.1 objExl.DisplayAlerts = False

3 知识点

3.1 CreateObject

3.2 Excel.Application

3.3 Workbooks

3.3.1 工作簿集合

3.3.1.1 WorkBook

3.3.1.1.1 Worksheets

3.3.1.1.1.1 工作表集合

Worksheet

Cells单元格集合

CELL

3.3.2 有10个workbook

3.4 Me.Repaint

3.4.1 显式刷新

3.4.2 Doevents

3.5 objWb.SaveAs

3.5.1 另存为

4 程序要求

4.1 准确性

4.2 友好性

4.2.1 用户体验

4.2.1.1 用户满意度高

4.3 优化

4.4 稳定性

4.5 安全性

 

 

 

application_key  相关链接:

 

1. 直接超值购买:

       点击购买:  Button 

       包含:Access示例完整源码+实现思路与代码讲解高清视频+Access培训课件    绝对低价超值

 

2. 购买前咨询:

    

    在线咨询QQ:1918333016

    企业热线QQ:4008553990 (使用QQ搜索: 搜索服务)

    更多联系方式:http://www.office-cn.net/t/training/officecontact.htm

 

application_key  部分源码预览:

 

  access数据库

 

Option Compare Database
 
Private Sub cmdClose_Click()
 DoCmd.Close acForm, Me.Name
 DoCmd.Quit acQuitSaveNone
End Sub
 
 
Private Sub cmdExport_Click()
On Error GoTo err1
   
   '........................
   '........................
   
   lblStatus.Caption = "正在清空目标文件夹的旧xls文件...."
   Me.Repaint
   strFile = Dir(CurrentProject.Path & "\Output\*.*", vbReadOnly) '通配符*.*表示任意文件,如果想删除excel文件,用*.xl*
            While strFile <> ""  '判断文件名是否存在
               Kill CurrentProject.Path & "\Output\" & strFile '如果存在,则进行删除
               strFile = Dir
            Wend
 
 
    Dim i As Long
    Dim j As Long
    Dim objExl As Object 'Excel.Application   '声明对象变量
    Dim objWb As Object
    Dim objWs As Object
    Dim lngStartRow As Long
    Dim lngStartCol As Long
    
    Dim lngPagRows As Long
    
    Dim lngSeqNo As Long
    
    Dim lngFileNo As Long
    Dim lngTmp As Long
    
    lngStartRow = 17
    lngStartCol = 1
    
    lngPagRows = 20 '每页20行
    
    DoCmd.Hourglass True            '改变鼠标样
    Set objExl = CreateObject("Excel.APPLICATION") 'Set objExl = New Excel.Application '初始化对象变量
    
    
    Dim rsTotal As New ADODB.Recordset
    lblStatus.Caption = "正在打开汇总后的数据...."
    Me.Repaint
    '源数据
    rsTotal.Open "select * from tblTotal order by FMark Desc,FID", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    objExl.DisplayAlerts = False
    If FShowExcelApp.Value <> 0 Then
       objExl.Visible = True
    End If
    
'........................
'........................
    '循环记录集中每一条记录 循环一条,导出一条
    Do While Not rsTotal.EOF
        If lngSeqNo Mod 20 = 0 Then
'          If lngFileNo <> 0 Then
'            objWb.SaveAs CurrentProject.Path & "\Output\File" & lngFileNo + 1 & ".xls"
'            objWb.Close True
'          End If
          lngFileNo = lngFileNo + 1
          If FMultiXlsFiles.Value <> 0 Then
            If Not (objWb Is Nothing) Then objWb.Close True
            
            Set objWb = objExl.Workbooks.Open(CurrentProject.Path & "\Tpl.xlt") '打开模板
            
            '39 是excel2003 56是excel2007 -4143 是默认格式也可以用
            objWb.SaveAs CurrentProject.Path & "\Output\File" & lngFileNo & ".xls", -4143 '39,56 'xlExcel8 56
            
            
            'objExl.Visible = True
            Set objWs = objWb.Worksheets(1)
            '........................
            '........................
          End If
          
          lngSeqNo = 0
        End If
        
       '........................
       '........................
        lngSeqNo = lngSeqNo + 1
       ' objExl.Visible = True                          '使EXCEL可见
        
         rsTotal.MoveNext
    Loop
    
    If Me.FMultiXlsFiles.Value = 0 Then
 
      objWb.Worksheets(1).Delete
      
       '........................
       '........................
                
 
          
      End If
      If FCreateDetailListFile.Value <> 0 Then
                  objWb.Worksheets.Add After:=objWb.Worksheets(objWb.Worksheets.Count)
                  objWb.Worksheets(objWb.Worksheets.Count).Select
                  objWb.Worksheets(objWb.Worksheets.Count).Name = "原始明细清单"
                
                  Set objWs = objWb.Worksheets(objWb.Worksheets.Count)
                lngSeqNo = 0
                lngStartRow = 1
                lngStartCol = 1
                'On Error GoTo 0
                If rsTotal.State = 1 Then rsTotal.Close
               '........................
               '........................
                 
                 objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 19).Value = ("MODEL")
                 objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 20).Value = ("QUALITY")
                 objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 21).Value = ("QUANTITY")
                 objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 22).Value = ("AMOUNT")
                 objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 23).Value = ("TOT_NET_WEIGHT")
                
                lngSeqNo = lngSeqNo + 1
                Do While Not rsTotal.EOF
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol).Value = lngSeqNo
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 1).Value = rsTotal("PAC1")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 2).Value = rsTotal("PAC2")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 3).Value = rsTotal("CN_FAMILY")
                   
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 4).Value = rsTotal("CN_ORIGIN")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 5).Value = rsTotal("CURRENCY")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 6).Value = rsTotal("DESC_SECTION")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 7).Value = rsTotal("TARIFF_GROUP")
                    
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 8).Value = rsTotal("%COMP1")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 9).Value = rsTotal("CN_COMP1")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 10).Value = rsTotal("%COMP2")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 11).Value = rsTotal("CN_COMP2")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 12).Value = rsTotal("%COMP3")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 13).Value = rsTotal("CN_COMP3")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 14).Value = rsTotal("%COMP4")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 15).Value = rsTotal("CN_COMP4")
                    
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 16).Value = rsTotal("%COMP5")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 17).Value = rsTotal("CN_COMP5")
                    
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 18).Value = rsTotal("BUNDLE")
  
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 19).Value = rsTotal("MODEL")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 20).Value = rsTotal("QUALITY")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 21).Value = rsTotal("QUANTITY")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 22).Value = rsTotal("AMOUNT")
                    objWs.Cells(lngStartRow + lngSeqNo, lngStartCol + 23).Value = rsTotal("TOT_NET_WEIGHT")
 
            
                    lngSeqNo = lngSeqNo + 1
                    lblStatus.Caption = "正在导出原始明细第" & lngSeqNo & "条数据...."
                    Me.Repaint
                  rsTotal.MoveNext
                Loop
      End If
      
      
      
      
    End If
    
    
   '........................
   '........................
err1:
'objExl.SheetsInNewWorkbook = 3
DoCmd.Hourglass False
lblStatus.Caption = "正在出错!"
Me.Repaint
If Err.Number = 70 Then
   MsgBox "生成报关单出错了,你可能正在打开Output目录下生成的EXCEL文件或其它Excel文件!" & vbCrLf & "请先关闭所有打开的Excel文件,再
 
按导出"
Else
   MsgBox "生成报关单出错了,错误号:" & Err.Number & "-" & Err.Description
End If
If Not (objExl Is Nothing) Then
    On Error Resume Next
    objExl.DisplayAlerts = False  '关闭时不提示保存
    objExl.Quit                '关闭EXCEL
    objExl.DisplayAlerts = True   '关闭时提示保存
    Set objExl = Nothing
End If
 
 'MsgBox "生成报关单出错了!" & Err.Description
 
End Sub
 
 
 
Private Sub cmdOpenFolder_Click()
 ' Shell "explorer.exe " & CurrentProject.Path & "\Output\", 1
  Application.FollowHyperlink CurrentProject.Path & "\Output\"  '打开速度比上面的代码快很多
End Sub
 
 
 
 
 
Private Sub Form_Load()
 
 Dim rs As ADODB.Recordset
 Set rs = New ADODB.Recordset
 rs.Open "select * from tblProcConfig", CurrentProject.Connection, adOpenStatic, adLockReadOnly
 If Not rs.EOF Then
   Me.FCreateDetailListFile.Value = Nz(rs("FCreateDetailListFile"))
   Me.FCreateListFile.Value = Nz(rs("FCreateListFile"))
   Me.FMultiXlsFiles.Value = Nz(rs("FMultiXlsFiles"))
   Me.FShowExcelApp.Value = Nz(rs("FShowExcelApp"))
   
 End If
 rs.Close
 
End Sub
 
Private Sub Form_Resize()
  Me.sfmSubform1.Width = Me.InsideWidth - Me.sfmSubform1.Left
  Me.sfmSubform2.Width = Me.InsideWidth - Me.sfmSubform2.Left
 ' Me.sfmSubform.Height = Me.InsideHeight - Me.Section(acHeader).Height - Me.Section(acFooter).Height - Me.sfmSubform.Top
End Sub
 
Private Function GetTariffGroup(strTARIFFGROUP As String) As String
        
         Select Case Trim(Nz(strTARIFFGROUP))
          Case "W O V E N"
           GetTariffGroup = "机织"
          Case "K N I T T E D"
           GetTariffGroup = "针织" '梭织
          Case Else
           GetTariffGroup = strTARIFFGROUP
         End Select
 
End Function
 
Private Function GetDescSection(strDescSection As String) As String
       
         Select Case Trim(Nz(strDescSection))
          Case "MAN"
           GetDescSection = "男式"
          Case "WOMAN"
           GetDescSection = "女式"
          Case Else
           GetDescSection = strDescSection
         End Select
 
End Function
 
 
    '    objExl.SheetsInNewWorkbook = 1  '将新建的工作薄数量设为1
    '    objExl.Workbooks.Add           '增加一个工作薄
    '    objExl.Sheets(1).Name = "book1"  '改变新工作薄的名称
    '    objExl.Sheets.Add               '再次增加一个工作薄
    '    objExl.Sheets(1).Name = "book2"  '修改工作薄名称
    '    objExl.Sheets("book2").Select     '选中工作薄
    '    For i = 1 To 5                   '循环写入数据
    '        For j = 1 To 5
    '            objExl.Cells(i, j).Select
    ' objExl.Selection.NumberFormatLocal = "@"   '设置为文本格式
    '            objExl.Cells(i, j) = i & j
    '        Next
    '    Next
    '    objExl.Sheets("book1").Select    '选中工作薄
    '    For i = 5 To 10                '循环写入数据
    '        For j = 5 To 10
    '            objExl.Cells(i, j).Select
    ' objExl.Selection.NumberFormatLocal = "@"   '设置为文本格式
    '            objExl.Cells(i, j) = i & j
    '        Next
    '    Next
    '    objExl.Sheets("book1").Select                   '选中工作薄
    '    objExl.ActiveWindow.View = xlPageBreakPreview  '设置显示方式
    '    objExl.ActiveWindow.Zoom = 100               '设置显示大小
    '   '   加密
    '    objExl.activesheet.Protect "123", DrawingObjects:=True, Contents:=True, Scenarios:=True
    '    objExl.Sheets("book2").Select                   '选中工作薄
    '    objExl.ActiveWindow.View = xlPageBreakPreview  '设置显示方式
    '    objExl.ActiveWindow.Zoom = 100               '设置显示大小
    '   '加密
    '    objExl.activesheet.Protect "123", DrawingObjects:=True, Contents:=True, Scenarios:=True
 
Private Function DelSpecialChar(strChar As String) As String
  '必须要用chrw 及 vbBinaryCompare才能替换掉不可见的 unicode字符
  strChar = Replace(strChar, ChrW(160), "", , , vbBinaryCompare)
 
'  strChar = Replace(strChar, Chr(63), "")
'  strChar = Replace(strChar, vbCrLf, "")
'  strChar = Replace(strChar, Chr(13), "")
'  strChar = Replace(strChar, Chr(10), "")
'  strChar = Replace(strChar, Chr(0), "")
  DelSpecialChar = strChar
End Function
 
Private Function ChkDupli()
 
     Dim rs As New ADODB.Recordset
    Dim rsOther As New ADODB.Recordset
    
     
   '........................
   '........................
             CurrentProject.Connection.Execute "delete * from tblTotalOther where FItemCode='" & rs("FItemCode") & "' and 
 
FOrigin='" & rs("FOrigin") & "' and FCurrency='" & rs("FCurrency") & "' and FManWoman='" & rs("FManWoman") & "' and FTariffGroup='" 
 
& rs("FTariffGroup") & "'"
          End If
       End If
       rsOther.Close
       
       rs.MoveNext
    Loop
    rs.Close
End Function
 
 
 
Private Sub Form_Unload(Cancel As Integer)
  DoCmd.Quit acQuitSaveAll
End Sub
 
Private Sub pagMain_Change()
  If pagMain.Value = 0 Then
    pagMain2.Visible = True
    FIsGroupByItemName.Value = Nz(DLookup("FIsGroupByItemName", "tblProcConfig"), 0)
    
  Else
    pagMain2.Visible = False
  End If
End Sub
 
Private Sub pagMain_Click()
 
End Sub
 
Private Sub sfmSubform1_Enter()
  gintCurrPos = 0
  Call sfmSubform1.Form.Form_Current
End Sub
 
Private Sub sfmSubform3_Enter()
  gintCurrPos = 1
  Call sfmSubform3.Form.Form_Current
  'Call Forms("frmImport").sfmSubform3.Form.Form_Current
End Sub
 
 
 
Public Function UpdCfg()
 Dim rs As ADODB.Recordset
 Set rs = New ADODB.Recordset
 rs.Open "select * from tblProcConfig", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
 If Not rs.EOF Then
   rs("FCreateDetailListFile") = Nz(Me.FCreateDetailListFile.Value)
   rs("FCreateListFile") = Nz(Me.FCreateListFile.Value)
   rs("FMultiXlsFiles") = Nz(Me.FMultiXlsFiles.Value)
   rs("FShowExcelApp") = Nz(Me.FShowExcelApp.Value)
   rs.Update
 End If
 rs.Close
End Function

 

发布人:zstmtony  
分享到:
点击次数:  更新时间:2018-02-28 11:12:47  【打印此页】  【关闭】
上一条:access图片文件保存到数据库的通用技巧-Access经典源码剖析  下一条:网站数据提取与采集-Access经典源码剖析



相关文章

  • • Access自动播音员-Access经典源码剖析
  • • Access智能搜索组合框-Access经典源码剖析
  • • Access自动执行宏的妙用-Access经典源码剖析
  • • access图片分页展示及选择功能-Access经典源码剖析
  • • 通用读取文本文件模块-Access经典源码剖析
  • • Access通用TAB键和默认值设置-Access经典源码剖析
  • • access图片文件保存到数据库的通用技巧-Access经典源码剖析

热门文章

  • [2018-02-28] 数据自动导出多个Excel或者多个工作表-Access经典源码剖析access数据库
  • [2018-02-28] Access调用网页功能-中英自动翻译功能-Access经典源码剖析access数据库
  • [2018-02-28] 能排序的列表框-Access经典源码剖析access数据库
  • [2018-02-28] Access专业工资条打印-Access经典源码剖析access数据库
  • [2018-02-28] Access调用网页功能-版本自动更新-Access经典源码剖析access数据库
  • [2019-04-19] Access自动播音员-Access经典源码剖析access数据库

热门产品

  1. 短信专家接口(可用于企业及个人多种短信用途)

    短信专家接口(可用于企业及个人多种短信用途)

  2. 通用票据打印软件

    通用票据打印软件

  3. Access加密狗系统4.05新版发布

    Access加密狗系统4.05新版发布

公司动态|在线留言|在线反馈|联系我们|友情链接|会员中心|站内搜索|网站地图

中山市天鸣科技发展有限公司 版权所有 1999-2018 粤ICP备10043721号

广东省中山市西苑广场富贵阁20楼A座

电话:0760-88315075 手机:13928102596 QQ:1918333016

Access应用 Access培训 Access开发 Access平台

access|数据库|access下载|access教程|access视频|access软件

Powered by MetInfo 5.3.12 ©2008-2022  www.metinfo.cn