ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: opiona

[原创] 工作簿汇总,工作表汇总合并,多文件汇总合并 通用代码 支持多层子文件夹

    [复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-5-5 08:48 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
ansen__111 发表于 2018-5-4 17:03
总公司设计了一套excel工作表,在一个工作簿中,每个工作表的行是所有下属公司名称(比如a1是北京公司,a2 ...

14885553.rar (248.73 KB, 下载次数: 1113)

  1.     Rem 清空汇总表原有数据,保留标题
  2.     Set SH1 = Sheets("表一")
  3.     Set SH2 = Sheets("表二")
  4.     SH1.Range("C5:I65536").ClearContents
  5.     SH2.Range("D5:J65536").ClearContents
  6.    
  7.     Rem 获取文件清单
  8.     FileArr = FileAllArr(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, True, False)
  9.     If FileArr(0) <> "" Then  '//如果文件清单 不是空白的
  10.         ICOUNT = UBound(FileArr) + 1
  11.         Rem 遍历每个分表文件
  12.         For I = 0 To ICOUNT - 1
  13.             StrNameFile = GetPathFromFileName(FileArr(I), False)
  14.             Rem  提示信息,在状态栏显示
  15.             Application.StatusBar = "文件总数:" & ICOUNT & " 当前是第:" & I + 1 & " 当前提取的文件是:" & StrNameFile
  16.             DoEvents
  17.             
  18.             Rem  确认公司名,假设表一中有的,表二也有
  19.             StrNameGS = ""
  20.             FROW = 0
  21.             For IROW = 6 To SH1.Range("A65536").End(3).Row
  22.                 If InStr(SH1.Cells(IROW, 1).Value, StrNameFile) > 0 Then
  23.                     StrNameGS = SH1.Cells(IROW, 1).Value
  24.                     FROW = IROW
  25.                     Exit For
  26.                 End If
  27.             Next
  28.             If FROW > 0 Then
  29.                 Set WB = Workbooks.Open(FileArr(I))
  30.                 Rem  表一
  31.                 Set SHN = WB.Worksheets("" & SH1.Name)
  32.                 Rem 找到分表中公司所在行
  33.                 Set C = SHN.Range("A:A").Find(StrNameGS, , LOOKAT:=xlWhole)
  34.                 If Not C Is Nothing Then
  35.                     Rem 将此行数据复制到汇总表对应行中
  36.                     For ICOL = 3 To 9
  37.                         SH1.Cells(FROW, ICOL).Value = SHN.Cells(C.Row, ICOL).Value
  38.                     Next
  39.                 End If
  40.                
  41.                 Rem  表 二
  42.                 Set C = SH2.Range("A:A").Find(StrNameGS, , LOOKAT:=xlWhole)
  43.                 If Not C Is Nothing Then
  44.                     FROW = C.Row
  45.                 End If
  46.                 Set SHN = WB.Worksheets("" & SH2.Name)
  47.                 Set C = SHN.Range("A:A").Find(StrNameGS, , LOOKAT:=xlWhole)
  48.                 If Not C Is Nothing Then
  49.                     For ICOL = 4 To 10
  50.                         SH2.Cells(FROW, ICOL).Value = SHN.Cells(C.Row, ICOL).Value
  51.                         SH2.Cells(FROW + 1, ICOL).Value = SHN.Cells(C.Row + 1, ICOL).Value
  52.                     Next
  53.                 End If
  54.                
  55.                 WB.Close False
  56.             End If
  57.         Next I
  58.     End If
复制代码

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-5-7 11:17 | 显示全部楼层

多谢大神!!!太感谢了!!!

TA的精华主题

TA的得分主题

发表于 2018-5-7 17:15 | 显示全部楼层
精华帖,占位置,谢谢大师分享!

TA的精华主题

TA的得分主题

发表于 2018-5-8 08:37 | 显示全部楼层
感谢分享,我的电脑WIN7 64位,office2016,只安装了excel ,word,ppt,未安装过AccessDatabaseEngine,使用未出现报错现象。
套表功能强大,速度快,如果在合并前自动将已有合并数据清空(合并条件除外),就更完善了。

TA的精华主题

TA的得分主题

发表于 2018-5-8 08:43 | 显示全部楼层
本帖最后由 djs5212720 于 2018-5-8 10:13 编辑

5_多工作簿指定工作表,全部数据汇总,运行时时发现越界报错-9
请问老师这会是什么引起的报错!
Dim T
    T = Timer  '//开始时间
   
    Dim SQLARR
    Dim I, X As Integer
    Dim Str_coon, StrSQL As String
    Dim SH1, SH0, SHW As Worksheet
   
    Set SH1 = Sheets("汇总")   这里报错
    SH1.Range("A4:HZ1048576").ClearContents
   
    Rem 组合查询标题
    StrBT = ""
    For ICOL = 3 To SH1.Range("HZ3").End(xlToLeft).Column
        StrBT = StrBT & ",[" & SH1.Cells(3, ICOL).Value & "]"
    Next
   

TA的精华主题

TA的得分主题

发表于 2018-5-8 09:40 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-5-8 13:29 | 显示全部楼层
djs5212720 发表于 2018-5-8 08:43
5_多工作簿指定工作表,全部数据汇总,运行时时发现越界报错-9
请问老师这会是什么引起的报错!
Dim T

Set SH1 = Sheets("汇总")   这里报错
改成:Set SH1 = workSheets("汇总")    '//试试

TA的精华主题

TA的得分主题

发表于 2018-5-8 16:51 | 显示全部楼层
opiona 发表于 2018-5-8 13:29
Set SH1 = Sheets("汇总")   这里报错
改成:Set SH1 = workSheets("汇总")    '//试试

问题依旧,还是会报错的!

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-5-9 09:36 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
djs5212720 发表于 2018-5-8 16:51
问题依旧,还是会报错的!

检查是否存在工作表:汇总

TA的精华主题

TA的得分主题

发表于 2018-5-15 11:15 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
opiona 发表于 2018-5-9 09:36
检查是否存在工作表:汇总

存在的!还会有什么问题会导致这样结果?/
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-5 17:22 , Processed in 0.042939 second(s), 7 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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