查看: 9433|回复: 22
同一个文件夹中不同工作簿中多个工作表汇总
阅读权限20
在线时间 小时
老师们，你们好！
& && && && &&&附件里是同一个文件中有4个工作薄，其中有一个工作薄是汇总表，其他三张工作薄是被汇总的对象，且每个工作薄中的工作表的数量不一样，每张工作表有颜色标注的区域字段结构是一致的，如何通过VBA编程实现将三张工作薄中有颜色标注区域数据汇总到名字为&汇总表&这张工作薄里，请老师们不吝赐教，万分感激！
14:54 上传
点击文件名下载附件
49.73 KB, 下载次数: 334
阅读权限95
在线时间 小时
本帖最后由 zhaogang1960 于
17:42 编辑
发错板块了
请测试: Sub Macro1()
& & Dim cnn As Object, SQL$, MyPath$, MyFile$, m%
& & Dim cat As Object, MyTable As Object, s$
& & Set cnn = CreateObject(&adodb.connection&)
& & Set cat = CreateObject(&ADOX.Catalog&)
& & MyPath = ThisWorkbook.Path & &\&
& & MyFile = Dir(MyPath & &*.xls&)
& & While MyFile && &&
& && &&&If MyFile && ThisWorkbook.Name Then
& && && && &m = m + 1
& && && && &If m = 1 Then
& && && && && & cnn.Open &Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=& & MyPath & MyFile
& && && && &Else
& && && && && & t = &[Excel 8.0;hdr=Database=& & MyPath & MyFile & &].&
& && && && &End If
& && && && &cat.ActiveConnection = &Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=& & MyPath & MyFile
& && && && &For Each MyTable In cat.Tables
& && && && && & If MyTable.Type = &TABLE& Then
& && && && && && &&&s = Replace(MyTable.Name, &'&, &&)
& && && && && && &&&If Right(s, 1) = &$& Then
& && && && && && && && &If SQL && && Then SQL = SQL & & union all &
& && && && && && && && &SQL = SQL & &select f3,f4,f5,f19,f20,f21,f22,f23,f24,f25,f26,f27 from & & t & &[& & s & &A6:AA13]&
& && && && && && &&&End If
& && && && && & End If
& && && && &Next
& && &&&End If
& && &&&MyFile = Dir()
& & ActiveSheet.UsedRange.Offset(3, 1).ClearContents
& & [c4].CopyFromRecordset cnn.Execute(SQL)
& & cnn.Close
& & Set cnn = Nothing
& & Set cat = Nothing
& & Set MyTable = Nothing
阅读权限95
在线时间 小时
(52.96 KB, 下载次数: 1127)
17:43 上传
点击文件名下载附件
阅读权限20
在线时间 小时
老师，太感谢你了！解决我大问题了！
阅读权限20
在线时间 小时
& & & & & & & &
zhaogang1960&&老师，你好！
& && && & 首先非常感谢您在百忙之中给我回帖，同时为你的VBA高超水平所敬佩，您的程序基本解决了我的问题了，当还有一点小小的改进，不知道能不能实现，改进的要求是：将每张表的名称填充到汇总表&部门&这一列里，例如将工作表名称为A1填充到汇总表&部门&这一列里，而且其他几张工作薄中的每张表的行数是不固定，即每个月的人员姓名有增减变动，并且每张表里的合计行在汇总表里不显示出来，但在汇总表最后一行进行汇总。麻烦老师帮我看看，非常感谢了。{:soso_e113:}
09:01 上传
点击文件名下载附件
58.61 KB, 下载次数: 84
阅读权限95
在线时间 小时
本帖最后由 zhaogang1960 于
10:42 编辑
想唱歌的老虎 发表于
zhaogang1960&&老师，你好！
& && && & 首先非常感谢您在百忙之中给我回帖，同时为你的VBA高超水平所敬佩 ...
Sub Macro1()
& & Dim cnn As Object, SQL$, MyPath$, MyFile$, m%
& & Dim cat As Object, MyTable As Object, s$
& & Set cnn = CreateObject(&adodb.connection&)
& & Set cat = CreateObject(&ADOX.Catalog&)
& & MyPath = ThisWorkbook.Path & &\&
& & MyFile = Dir(MyPath & &*.xls&)
& & While MyFile && &&
& && &&&If MyFile && ThisWorkbook.Name Then
& && && && &m = m + 1
& && && && &If m = 1 Then
& && && && && & cnn.Open &Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=& & MyPath & MyFile
& && && && &Else
& && && && && & t = &[Excel 8.0;hdr=Database=& & MyPath & MyFile & &].&
& && && && &End If
& && && && &cat.ActiveConnection = &Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=& & MyPath & MyFile
& && && && &For Each MyTable In cat.Tables
& && && && && & If MyTable.Type = &TABLE& Then
& && && && && && &&&s = Replace(MyTable.Name, &'&, &&)
& && && && && && &&&If Right(s, 1) = &$& Then
& && && && && && && && &If SQL && && Then SQL = SQL & & union all &
& && && && && && && && &SQL = SQL & &select '& & Replace(s, &$&, &&) & &',f3,f4,f5,f19,f20,f21,f22,f23,f24,f25,f26,f27 from & & t & &[& & s & &A6:AA] where f3&&'合计'&
& && && && && && &&&End If
& && && && && & End If
& && && && &Next
& && &&&End If
& && &&&MyFile = Dir()
& & Wend
& & ActiveSheet.UsedRange.Offset(3, 1).ClearContents
& & [b4].CopyFromRecordset cnn.Execute(SQL)
& & cnn.Close
& & Set cnn = Nothing
& & Set cat = Nothing
& & Set MyTable = Nothing
End Sub
复制代码
阅读权限95
在线时间 小时
5楼附件中的&姓名&列不统一，下面附件使用原来的
(54.03 KB, 下载次数: 390)
10:44 上传
点击文件名下载附件
阅读权限20
在线时间 小时
zhaogang1960&&老师，你好！
& && && && &&&真的很感谢你的热情的指导,同时我也受益匪浅,你的程序帮了我大忙了,最后,就是还有以一个小小的假设,不知道在假设的出现的情况,通过您的程序能否实现,假设的情况如下:假设有时候有的分表中列字段会有增减变动，但汇总表的列字段是固定不变，这种情况能实现汇总功能吗？而且我还想实现每次汇总后总是按照从工作薄名为&12年9月XZ&中第一张表C1表开始到工作薄名为&12年9月XL&中最后一张表B4表止顺序从上到下进行排序显示在汇总表中。请老师帮忙看看,十分感谢!!!
13:50 上传
点击文件名下载附件
66.6 KB, 下载次数: 110
阅读权限95
在线时间 小时
想唱歌的老虎 发表于
zhaogang1960&&老师，你好！
& && && && &&&真的很感谢你的热情的指导,同时我也受益匪浅,你的程序帮了我大 ...
如果每个工作表表头规范，是可以实现的，不过你的附件表头占有3行，且有合并单元格，特别是有些列没有标题(见下图)，所以新要求不好实现
捕获.JPG (11.51 KB, 下载次数: 10)
14:05 上传
阅读权限30
在线时间 小时
不错，学习一下
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师君，已阅读到文档的结尾了呢~~
省三级选择题题库文件文件,题库,三级,选择题题库,省三级,选择题,试题题库,幸福选择题,毛概选择题,反馈意见
扫扫二维码，随身浏览文档
手机或平板扫扫即可继续访问
省三级选择题题库文件
举报该文档为侵权文档。
举报该文档含有违规或不良信息。
反馈该文档无法正常浏览。
举报该文档为重复文档。
推荐理由：
将文档分享至：
分享完整地址
文档地址：
粘贴到BBS或博客
flash地址：
支持嵌入FLASH地址的网站使用
html代码：
&embed src='/DocinViewer-4.swf' width='100%' height='600' type=application/x-shockwave-flash ALLOWFULLSCREEN='true' ALLOWSCRIPTACCESS='always'&&/embed&
450px*300px480px*400px650px*490px
支持嵌入HTML代码的网站使用
您的内容已经提交成功
您所提交的内容需要审核后才能发布，请您等待！
3秒自动关闭窗口