工作簿汇总，工作表汇总合并，多文件汇总合并 通用代码 支持多层子文件夹

opiona

ansen__111 发表于 2018-5-4 17:03
总公司设计了一套excel工作表，在一个工作簿中，每个工作表的行是所有下属公司名称（比如a1是北京公司，a2 ...

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

2018-5-5 08:47 上传

点击文件名下载附件

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

复制代码

ansen__111

opiona 发表于 2018-5-5 08:48

多谢大神！！！太感谢了！！！

qinmj2011

精华帖，占位置，谢谢大师分享！

bosao

感谢分享，我的电脑WIN7 64位，office2016，只安装了excel ，word，ppt，未安装过AccessDatabaseEngine，使用未出现报错现象。
套表功能强大，速度快，如果在合并前自动将已有合并数据清空（合并条件除外），就更完善了。

djs5212720

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
   

qihang15

感谢分享，学习一下。

opiona

djs5212720 发表于 2018-5-8 08:43
5_多工作簿指定工作表，全部数据汇总，运行时时发现越界报错-9
请问老师这会是什么引起的报错！
Dim T

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

djs5212720

opiona 发表于 2018-5-8 13:29
Set SH1 = Sheets("汇总")   这里报错
改成：Set SH1 = workSheets("汇总")    '//试试

问题依旧，还是会报错的！

opiona

djs5212720 发表于 2018-5-8 16:51
问题依旧，还是会报错的！

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

djs5212720

opiona 发表于 2018-5-9 09:36
检查是否存在工作表：汇总

存在的！还会有什么问题会导致这样结果？/