如何汇总一个文件夹下多个工作薄各工作表到汇总表的各工作表中

zhaogang1960

请看附件
如何汇总一个文件夹下多个工作薄各工作表到汇总表的各工作表中2.rar (28.97 KB, 下载次数: 185)

2013-7-16 17:56 上传

点击文件名下载附件

horse0918

真巧，我目前也在研究学习此方法。现在完成差不多了，完了上传
基本思路同楼主，不同的是：我想编程应更多地考虑实际情况或可变情况，故在汇总文件中设置一个参数表，记录各文件中需要待汇总表的单元格信息，
这样就可以解决不同格式，或不同汇围内的汇总，同时也可以定参数显示至需要的表的位置。在表中还需考虑单元格合并的情况 。

yzyyyyyyy

zhaogang1960 发表于 2013-7-16 17:56
请看附件

感谢zhaogang1960版主的热心帮助，解决了一大难题。各个文件汇总后，能否同时提取每个数据位置的序号顺序及文件名前的序号，以便于与原证书对照（证书复印件上已标记了这样的序号，附件-序号），即红色部分。另外有的附件中没有信息，统计数字变成了-1，应为0；有的附件数据较多，如001的附件1，无法完整提取。 如何汇总一个文件夹下多个工作薄各工作表到汇总表的各工作表中0717.rar (38.73 KB, 下载次数: 33)

2013-7-17 10:01 上传

点击文件名下载附件

yzyyyyyyy

yzyyyyyyy 发表于 2013-7-17 10:01
感谢zhaogang1960版主的热心帮助，解决了一大难题。各个文件汇总后，能否同时提取每个数据位置的序号顺 ...

感谢zhaogang1960 版主的热心帮助，13楼附件，需要提取文件名前的序号        附件-序号        文件名前序号-附件-序号，3项内容，即汇总表中的红色字部分。

zhaogang1960

1. 
   
2. Sub Macro1()
   
3.     Dim MyPath$, MyName$, sh As Worksheet, d As Object, arrsh, wb As Workbook, i&, t
   
4.     Dim arr(1 To 1000, 1 To 11), m&, rng As Range, arrt(), x As WorksheetFunction
   
5.     Application.ScreenUpdating = False
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     arrsh = Array("A6:L15", "A4:H14", "A5:H15", "A5:J16", "A4:H14")
   
8.     For i = 1 To Sheets.Count - 1
   
9.         If InStr(Sheets(i).Name, "附件") Then
   
10.             Sheets(i).Range(arrsh(i - 1)).Resize(1000, 26).Clear
    
11.             d(Sheets(i).Name) = i
    
12.         End If
    
13.     Next
    
14.     Set wb = ThisWorkbook
    
15.     Set x = WorksheetFunction
    
16.     MyPath = ThisWorkbook.Path & ""
    
17.     MyName = Dir(MyPath & "*.xls")
    
18.     Do While MyName <> ""
    
19.         If MyName <> ThisWorkbook.Name Then
    
20.             m = m + 1
    
21.             arr(m, 1) = m
    
22.             arr(m, 2) = Replace(MyName, ".xls", "")
    
23.             arr(m, 3) = Split(MyName, "-")(0)
    
24.             arr(m, 4) = "姓名" & m
    
25.             arr(m, 5) = Split(arr(m, 2), "-")(2)
    
26.             With GetObject(MyPath & MyName)
    
27.                 For Each sh In .Sheets
    
28.                     t = d(sh.Name)
    
29.                     If t <> "" Then
    
30.                         Set rng = sh.Range(arrsh(t - 1))
    
31.                         r = sh.[b65536].End(xlUp).Row - rng.Row + 1
    
32.                         
    
33.                         If r > 0 Then
    
34.                             ReDim arrt(1 To r, 1 To 3)
    
35.                             arr(m, 6) = arr(m, 6) + r
    
36.                             arr(m, t + 6) = arr(m, t + 6) + r
    
37.                             With wb.Sheets(t)
    
38.                                 lr = .[a65536].End(xlUp).Row + 1
    
39.                                 rng.Copy .[a65536].End(xlUp).Offset(1)
    
40.                                 For k = 1 To r
    
41.                                     arrt(k, 1) = arr(m, 3)
    
42.                                     arrt(k, 2) = "'" & Replace(sh.Name, "附件", "") & "-" & k
    
43.                                     arrt(k, 3) = arr(m, 3) & "-" & Replace(sh.Name, "附件", "") & "-" & k
    
44.                                 Next
    
45.                                 c = rng.Columns.Count + 4
    
46.                                 If x.CountA(.Columns(c)) = 0 Then
    
47.                                     .Cells(rng.Row, c).Resize(r, 3) = arrt
    
48.                                 Else
    
49.                                     .Cells(65536, c).End(xlUp).Offset(1).Resize(r, 3) = arrt
    
50.                                 End If
    
51.                             End With
    
52.                         End If
    
53.                     End If
    
54.                 Next
    
55.                 .Close False
    
56.             End With
    
57.         End If
    
58.         MyName = Dir
    
59.     Loop
    
60.     With Sheets("统计表")
    
61.         .Range("A4:K65536").ClearContents
    
62.         [a4].Resize(m, 11) = arr
    
63.         .[f3:k3].FormulaR1C1 = "=SUM(R4C:R" & m + 3 & "C)"
    
64.     End With
    
65.     Application.ScreenUpdating = True
    
66. End Sub
    
67. 
    

复制代码

zhaogang1960

请看附件
如何汇总一个文件夹下多个工作薄各工作表到汇总表的各工作表中0717.rar (44.93 KB, 下载次数: 140)

2013-7-17 19:25 上传

点击文件名下载附件

zhaogang1960

1. 
   
2. Sub Macro1()
   
3.     Dim MyPath$, MyName$, sh As Worksheet, d As Object, arrsh, wb As Workbook, i&, t, col%, c As Range
   
4.     Dim arr(1 To 1000, 1 To 11), m&, rng As Range, arrt(), x As WorksheetFunction
   
5.     Application.ScreenUpdating = False
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     arrsh = Array("A6:L6", "A4:H4", "A5:H5", "A5:J5", "A4:H4")
   
8.     For i = 1 To Sheets.Count - 1
   
9.         If InStr(Sheets(i).Name, "附件") Then
   
10.             Sheets(i).Range(arrsh(i - 1)).Resize(1000, 26).Clear
    
11.             d(Sheets(i).Name) = i
    
12.         End If
    
13.     Next
    
14.     Set wb = ThisWorkbook
    
15.     Set x = WorksheetFunction
    
16.     MyPath = ThisWorkbook.Path & ""
    
17.     MyName = Dir(MyPath & "*.xls")
    
18.     Do While MyName <> ""
    
19.         If MyName <> ThisWorkbook.Name Then
    
20.             m = m + 1
    
21.             arr(m, 1) = m
    
22.             arr(m, 2) = Replace(MyName, ".xls", "")
    
23.             arr(m, 3) = Split(MyName, "-")(0)
    
24.             arr(m, 4) = "姓名" & m
    
25.             arr(m, 5) = Split(arr(m, 2), "-")(2)
    
26.             With GetObject(MyPath & MyName)
    
27.                 For Each sh In .Sheets
    
28.                     t = d(sh.Name)
    
29.                     If t <> "" Then
    
30.                         Set c = sh.UsedRange.Find("说明：", , , xlPart)
    
31.                         If Not c Is Nothing Then
    
32.                             l = c.Row - 1
    
33.                         Else
    
34.                             l = 1000
    
35.                         End If
    
36.                         Set rng = sh.Range(Left$(arrsh(t - 1), 4) & l)
    
37.                         r = sh.[b65536].End(xlUp).Row - rng.Row + 1
    
38.                         If r > 0 Then
    
39.                             ReDim arrt(1 To r, 1 To 3)
    
40.                             arr(m, 6) = arr(m, 6) + r
    
41.                             arr(m, t + 6) = arr(m, t + 6) + r
    
42.                             With wb.Sheets(t)
    
43.                                 lr = .[a65536].End(xlUp).Row + 1
    
44.                                 rng.Copy .[a65536].End(xlUp).Offset(1)
    
45.                                 For k = 1 To r
    
46.                                     arrt(k, 1) = arr(m, 3)
    
47.                                     arrt(k, 2) = "'" & Replace(sh.Name, "附件", "") & "-" & k
    
48.                                     arrt(k, 3) = arr(m, 3) & "-" & Replace(sh.Name, "附件", "") & "-" & k
    
49.                                 Next
    
50.                                 col = rng.Columns.Count + 4
    
51.                                 If x.CountA(.Columns(col)) = 0 Then
    
52.                                     .Cells(rng.Row, col).Resize(r, 3) = arrt
    
53.                                 Else
    
54.                                     .Cells(65536, col).End(xlUp).Offset(1).Resize(r, 3) = arrt
    
55.                                 End If
    
56.                             End With
    
57.                         End If
    
58.                     End If
    
59.                 Next
    
60.                 .Close False
    
61.             End With
    
62.         End If
    
63.         MyName = Dir
    
64.     Loop
    
65.     With Sheets("统计表")
    
66.         .Range("A4:K65536").ClearContents
    
67.         [a4].Resize(m, 11) = arr
    
68.         .[f3:k3].FormulaR1C1 = "=SUM(R4C:R" & m + 3 & "C)"
    
69.     End With
    
70.     Application.ScreenUpdating = True
    
71. End Sub

复制代码

yzyyyyyyy

zhaogang1960 发表于 2013-7-17 19:25
请看附件

感谢版主的热心帮助，有个问题，汇总表附件1中，001的数据多于10行，汇总不全，少了3行

zhaogang1960

yzyyyyyyy 发表于 2013-7-18 18:21
感谢版主的热心帮助，有个问题，汇总表附件1中，001的数据多于10行，汇总不全，少了3行

每个工作表中都有无用数据行，即下面的说明，让我考虑一下，从这个说明着手

zhaogang1960

请看附件
如何汇总一个文件夹下多个工作薄各工作表到汇总表的各工作表中0717.rar (44.86 KB, 下载次数: 164)

2013-7-18 18:43 上传

点击文件名下载附件