如何用VBA批量汇总同文件夹下多个工作薄数据

jy01309791

如何用VBA批量汇总同文件夹下多个工作薄数据表的标题和表头都一样！~求助大神！！帮帮忙！急急急

bajifeng

看了您的附件，没有发现汇总表
汇总表在哪里呢？

bajifeng

还有一个疑问，是汇总在同一个工作表里还是汇总在同一个工作簿的各个工作表里？

jy01309791

bajifeng 发表于 2016-1-15 19:22
还有一个疑问，是汇总在同一个工作表里还是汇总在同一个工作簿的各个工作表里？

汇总在一个新建的文档里

bajifeng

jy01309791 发表于 2016-1-15 19:22
汇总在一个新建的文档里

OK,新建文档

是汇总在同一个工作表里
还是汇总在同一个工作簿的各个工作表里？

jy01309791

bajifeng 发表于 2016-1-15 19:25
OK,新建文档

是汇总在同一个工作表里

一个工作表里

zhaogang1960

ADO法速度很快，请参考：

1. Sub ADO法()
   
2.     Dim cnn As Object, MyPath$, MyFile$, SQL$, m%
   
3.     MyPath = ThisWorkbook.Path & ""
   
4.     MyFile = Dir(MyPath & "*.xlsx")
   
5.     Application.ScreenUpdating = False
   
6.     Cells.ClearContents
   
7.     [a1:d1] = Array("序号", "村民小组", "户主姓名", "家庭人口 数")
   
8.     Set cnn = CreateObject("adodb.connection")
   
9.     Do While Len(MyFile)
   
10.         m = m + 1
    
11.         If m = 1 Then
    
12.             cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & MyPath & MyFile
    
13.             SQL = "select * from [Sheet0$a3:d] where 村民小组 is not null"
    
14.         Else
    
15.             SQL = "select * from [Excel 12.0;Database=" & MyPath & MyFile & "].[Sheet0$a3:d] where 村民小组 is not null"
    
16.         End If
    
17.         Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
18.         MyFile = Dir
    
19.     Loop
    
20.     With [a1].CurrentRegion
    
21.         .Value = .Value
    
22.     End With
    
23.     cnn.Close
    
24.     Set cnn = Nothing
    
25.    Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

zhaogang1960

附件……………………
六甲镇2015贫困户名单.rar (79.98 KB, 下载次数: 479)

2016-1-15 20:01 上传

点击文件名下载附件

chenbiao2012

1. Sub 汇总()
   
2.     Application.ScreenUpdating = False
   
3.     Dim brr(1 To 10000, 1 To 4)
   
4.     p = ThisWorkbook.Path & ""
   
5.     f = Dir(p & "*.xls*")
   
6.     Do While f <> ""
   
7.         If f <> ThisWorkbook.Name Then
   
8.             With GetObject(p & f)
   
9.                 With .Sheets(1)
   
10.                     r = .Cells(Rows.Count, 2).End(3).Row
    
11.                     arr = .Range("a4:d" & r)
    
12.                 End With
    
13.                  .Close 0
    
14.             End With
    
15.             For i = 1 To UBound(arr)
    
16.                 If IsNumeric(Val(arr(i, 1))) Then
    
17.                     n = n + 1
    
18.                     brr(n, 1) = n
    
19.                     For j = 2 To 4
    
20.                         brr(n, j) = arr(i, j)
    
21.                     Next
    
22.                 End If
    
23.             Next
    
24.         End If
    
25.         f = Dir
    
26.     Loop
    
27.     With Sheets(1)
    
28.         .[a1] = "行政村拟确定贫困户名单"
    
29.         .[a1].Resize(1, 4).Merge
    
30.         .[a2].Resize(n, 4) = brr
    
31.     End With
    
32.     Application.ScreenUpdating = True
    
33. End Sub
    

复制代码

bajifeng

1. Sub BJF()  'by: bajifeng
   
2. Dim brr(), arr, cn, cw()
   
3. Set sho = ThisWorkbook.ActiveSheet
   
4. sho.[A2:D9999].Clear
   
5. fl = ListFile(ThisWorkbook.Path, True, "*.xls?")
   
6. Application.ScreenUpdating = False
   
7. For l = 0 To UBound(fl)
   
8.     If fl(l) <> "" Then
   
9.         If InStr(fl(l), "汇总") = 0 Then
   
10.             Workbooks.Open fl(l)
    
11.             '+++++++++++++++++++++++++++++++++++++++
    
12.             For Each sht In Worksheets
    
13.                 n = n + 1
    
14.                 If sho.[a2] = "" Then
    
15.                     sht.Range("a4:d" & [b65536].End(3).Row).Copy sho.[a2]
    
16.                 Else
    
17.                     sht.Range("a4:d" & [b65536].End(3).Row).Copy sho.[a65536].End(3).Offset(2)
    
18.                 End If
    
19.             Next
    
20. 
    
21.             If n = 1 Then
    
22.                 cn = 4
    
23.                 ReDim cw(1 To cn)
    
24.                 For i = 1 To cn
    
25.                     cw(i) = Columns(i).ColumnWidth
    
26.                 Next
    
27.             End If
    
28. 
    
29.             '+++++++++++++++++++++++++++++++++++++++
    
30.             ActiveWorkbook.Close True
    
31.         End If
    
32.     End If
    
33. Next
    
34. '[a2:f999] = ""
    
35. '[a2].Resize(n, 5) = Application.Transpose(brr)
    
36. 'Columns("a:f").AutoFit
    
37. 
    
38. For k = 1 To cn
    
39.     Columns(k).ColumnWidth = cw(k)
    
40. Next
    
41. 
    
42. Application.ScreenUpdating = True
    
43. MsgBox "处理完毕！"
    
44. End Sub
    
45. Private Function ListFile(MuLu As String, Zi As Boolean, Optional LeiXing As String = "")
    
46. Dim MyFile As String, ms As String
    
47. Dim arr, brr, x
    
48. Dim i As Integer
    
49. Set d = CreateObject("Scripting.Dictionary")
    
50. If Left(MuLu, 1) <> "" Then MuLu = MuLu & ""
    
51. d.Add MuLu, ""
    
52. i = 0
    
53. Do While i < d.Count
    
54.     brr = d.keys
    
55.     MyFile = Dir(brr(i), vbDirectory)
    
56.     Do While MyFile <> ""
    
57.         If MyFile <> "." And MyFile <> ".." Then
    
58.             If (GetAttr(brr(i) & MyFile) And vbDirectory) = vbDirectory Then d.Add (brr(i) & MyFile & ""), ""
    
59.         End If
    
60.         MyFile = Dir
    
61.     Loop
    
62.     If Zi = False Then Exit Do
    
63.     i = i + 1
    
64. Loop
    
65. If LeiXing = "" Then
    
66.     ListFile = Application.Transpose(d.keys)
    
67. Else
    
68.     For Each x In d.keys
    
69.         MyFile = Dir(x & LeiXing)
    
70.         Do While MyFile <> ""
    
71.             ms = ms & x & MyFile & ","
    
72.             MyFile = Dir
    
73.         Loop
    
74.         If Zi = False Then Exit For
    
75.     Next
    
76.     If ms = "" Then ms = "没有符合要求的文件,"
    
77.     'ListFile = Application.Transpose(Split(ms, ","))   '下标从1开始
    
78.     ListFile = Split(ms, ",")   '下标从0开始
    
79. End If
    
80. End Function

复制代码