跨工作簿汇总

songyichaocn

平时经常遇到同一文件夹下多个工作薄（少时十几个，多时几百个）汇总工作，有没有简单的方法，听说vba可以，请大家帮忙，谢谢！请看附件汇总样式。 输机表.zip (20.23 KB, 下载次数: 162)

2014-3-10 15:24 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook$, mypath$, wjm$
   
6.   mypath = ThisWorkbook.Path & ""
   
7.   mybook = ThisWorkbook.FullName
   
8.   
   
9.   With cnn
   
10.     .Provider = "microsoft.jet.oledb.4.0"
    
11.     .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
    
12.     .Open
    
13.   End With
    
14.   
    
15.   wjm = Dir(mypath & "*.xls")
    
16.   Do While wjm <> ""
    
17.     If wjm <> "汇总.xls" Then
    
18.       sql = sql & "union all select * from [Excel 8.0;Database=" & mypath & wjm & "].[1.汇总$a2:l] where len(报告编号)<>0 and 报告编号<>'汇总' "
    
19.     End If
    
20.     wjm = Dir()
    
21.   Loop
    
22.   sql = Mid(sql, 11)
    
23.   rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
24.   With Worksheets("汇总表")
    
25.     .UsedRange.Offset(2, 0).Delete
    
26.     .Range("b3").CopyFromRecordset rs
    
27.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
28.     .Range("a3:a" & r).FormulaR1C1 = "=row()-2"
    
29.     .Range("a" & r + 1) = "合计"
    
30.     .Range(.Cells(r + 1, 7), .Cells(r + 1, 13)).FormulaR1C1 = "=SUM(R[" & 2 - r & "]C:R[-1]C)"
    
31.     With .Range("a1:m" & r + 1)
    
32.       .Borders.LineStyle = xlContinuous
    
33.       .HorizontalAlignment = xlCenter
    
34.       .VerticalAlignment = xlCenter
    
35.     End With
    
36.   End With
    
37.   rs.Close
    
38.   cnn.Close
    
39. End Sub
    

复制代码

chxw68

参见附件。

zhaogang1960

短信收到，请测试：

1. Sub Macro1()
   
2.     Dim MyPath$, MyName$, arr, brr(1 To 60000, 0 To 12), i&, j&, m&
   
3.     MyPath = ThisWorkbook.Path & ""
   
4.     MyName = Dir(MyPath & "*.xls")
   
5.     Application.ScreenUpdating = False
   
6.     Do While MyName <> ""
   
7.         If MyName <> ThisWorkbook.Name Then
   
8.             With GetObject(MyPath & MyName)
   
9.                 arr = .Sheets(1).[a1].CurrentRegion
   
10.                 For i = 3 To UBound(arr)
    
11.                     If Len(arr(i, 2)) Then
    
12.                         m = m + 1
    
13.                         brr(m, 0) = m
    
14.                         For j = 1 To 12
    
15.                             brr(m, j) = arr(i, j)
    
16.                         Next
    
17.                     End If
    
18.                 Next
    
19.                 .Close False
    
20.             End With
    
21.         End If
    
22.         MyName = Dir
    
23.     Loop
    
24.     [a1].CurrentRegion.Offset(2).ClearContents
    
25.     [a3].Resize(m, 13) = brr
    
26.     Cells(m + 3, 1) = "合计"
    
27.     Cells(m + 3, 7).Resize(, 7).FormulaR1C1 = "=SUM(R3C:R" & m + 2 & "C)"
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    

复制代码

zhaogang1960

请看附件
输机表.rar (24.59 KB, 下载次数: 278)

2014-3-10 15:49 上传

点击文件名下载附件

mmwwdd

记号，学习，反复学习，必须的

zhaogang1960

4楼代码适合于待合并工作簿较少的情况，如果工作薄多达几百个，仅用GetObject打开、关闭它们，其他什么也不操作也需要很长时间
下面代码使用ADO联合查询方法，如果待合并工作表超过49个，则分多次复制数据——将49个待合并的工作表为一组，构成一个联合查询SQL语句，并复制查询数据到汇总工作簿

1. Sub ADO联合查询()
   
2.     Dim cnn As Object, rs As Object, SQL$, MyPath$, MyFile$, m&, s$, r&
   
3.     Application.ScreenUpdating = False
   
4.     ActiveSheet.UsedRange.Offset(2).ClearContents
   
5.     MyPath = ThisWorkbook.Path & ""
   
6.     MyName = Dir(MyPath & "*.xls")
   
7.     Do While MyName <> ""
   
8.         If InStr(MyName, ThisWorkbook.Name) = 0 Then
   
9.             Set cnn = CreateObject("ADODB.Connection")
   
10.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyName
    
11.             Set rs = cnn.OpenSchema(20)
    
12.             Do Until rs.EOF '该Do循环将查找工作簿中的所有工作表
    
13.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
14.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
15.                     If Right(s, 1) = "$" Then
    
16.                         m = m + 1
    
17.                         If m > 49 Then
    
18.                             Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
19.                             m = 1
    
20.                             SQL = ""
    
21.                         End If
    
22.                         If Len(SQL) Then SQL = SQL & " union all "
    
23.                         SQL = SQL & "select * from [Excel 8.0;hdr=no;Database=" & MyPath & MyName & "].[" & s & "a3:l] where f2 is not null"
    
24.                     End If
    
25.                 End If
    
26.                 rs.MoveNext
    
27.             Loop
    
28.         End If
    
29.         MyName = Dir()
    
30.     Loop
    
31.     If Len(SQL) Then Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
32.     r = Cells(Rows.Count, 2).End(xlUp).Row
    
33.     Range("A3") = 1
    
34.     Range("A3").AutoFill Destination:=Range("A3:A" & r), Type:=xlFillSeries
    
35.     Cells(r + 1, 1) = "合计"
    
36.     Cells(r + 1, 7).Resize(, 7).FormulaR1C1 = "=SUM(R3C:R" & r & "C)"
    
37.     rs.Close
    
38.     cnn.Close
    
39.     Set rs = Nothing
    
40.     Set cnn = Nothing
    
41.     Application.ScreenUpdating = True
    
42. End Sub
    

复制代码

zhaogang1960

下面附件中有52个待合并工作簿，请比较两种方法的速度：
输机表.rar (261.73 KB, 下载次数: 538)

2014-3-10 16:29 上传

点击文件名下载附件

zhaogang1960

经测试，ADO+数组法比ADO联合查询速度更快：

1. Sub ADO加数组()
   
2. tt = Timer
   
3.     Dim cnn As Object, SQL$, Mypath$, MyName$, arr, brr(1 To 60000, -1 To 11), i&, j&, m&
   
4.     Application.ScreenUpdating = False
   
5.     Mypath = ThisWorkbook.Path & ""
   
6.     MyName = Dir(Mypath & "*.xls")
   
7.     Do While MyName <> ""
   
8.         If InStr(MyName, ThisWorkbook.Name) = 0 Then
   
9.             Set cnn = CreateObject("ADODB.Connection")
   
10.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & Mypath & MyName
    
11.             Set rs = cnn.OpenSchema(20)
    
12.             Do Until rs.EOF '该Do循环将查找工作簿中的所有工作表，如果仅取一个工作表，请说明该表的特征
    
13.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
14.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
15.                     If Right(s, 1) = "$" Then
    
16.                         SQL = "select * from [" & s & "a3:l] where f2 is not null"
    
17.                         arr = cnn.Execute(SQL).GetRows
    
18.                         For i = 0 To UBound(arr, 2)
    
19.                             m = m + 1
    
20.                             brr(m, -1) = m
    
21.                             For j = 0 To 11
    
22.                                 brr(m, j) = arr(j, i)
    
23.                             Next
    
24.                         Next
    
25.                     End If
    
26.                 End If
    
27.                 rs.MoveNext
    
28.             Loop
    
29.         End If
    
30.         MyName = Dir()
    
31.     Loop
    
32.     [a1].CurrentRegion.Offset(2).ClearContents
    
33.     [a3].Resize(m, 13) = brr
    
34.     Cells(m + 3, 1) = "合计"
    
35.     Cells(m + 3, 7).Resize(, 7).FormulaR1C1 = "=SUM(R3C:R" & m + 2 & "C)"
    
36.     cnn.Close
    
37.     Set cnn = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox Timer - tt
    
40. End Sub
    

复制代码

guojianlin1985

好贴，收藏备用。