多工作薄下多工作表汇总求和

qldd

求助：各位老师，现同文件夹下有多个工作薄，每个工作薄下有七个工作表，表名，格式都固定，各表下姓名偶有相同的，人数不同，要求按工作表名中的“姓名”汇总求和到各表

liulang0808

论坛里有不少类似的帖子，你查查吧
有些内容供你参考下
http://club.excelhome.net/thread-1072917-1-1.html
http://club.excelhome.net/thread-1058320-1-1.html
http://club.excelhome.net/thread-1080761-1-1.html

qldd

liulang0808 发表于 2013-12-30 10:24
论坛里有不少类似的帖子，你查查吧
有些内容供你参考下
http://club.excelhome.net/thread-1072917-1-1.h ...

谢谢liulang0808 老师的回复，发贴之前也找了一些例子，改了一些代码，但总是错误，还请您指教！！！

zhaogang1960

请测试：

1. Sub Macro1()
   
2.     Dim cnn As Object, SQL$(1 To 7), MyPath$, MyFile$, m&(1 To 7), n&, t$, shn$(1 To 7)
   
3.     Application.ScreenUpdating = False
   
4.     For i = 1 To 7
   
5.         Sheets(i).UsedRange.Offset(3).ClearContents
   
6.         shn(i) = Sheets(i).Name
   
7.     Next
   
8.     Set cnn = CreateObject("ADODB.Connection")
   
9.     MyPath = ThisWorkbook.Path & ""
   
10.     MyFile = Dir(MyPath & "*.xls")
    
11.     Do While MyFile <> ""
    
12.         If MyFile <> ThisWorkbook.Name Then
    
13.             n = n + 1
    
14.             If n = 1 Then
    
15.                 cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    
16.             Else
    
17.                 t = "[Excel 8.0;Database=" & MyPath & MyFile & "]."
    
18.             End If
    
19.             For i = 1 To 7
    
20.                 If Len(SQL(i)) Then SQL(i) = SQL(i) & " union all "
    
21.                 SQL(i) = SQL(i) & "select * from " & t & "[" & shn(i) & "$A3:H] where not 出勤天数 is null"
    
22.             Next
    
23.         End If
    
24.         MyFile = Dir()
    
25.     Loop
    
26.     For i = 1 To 7
    
27.         SQL(i) = "select 姓名,sum(出勤天数),sum(基本工资),sum(绩效工资),sum(各项保险),sum(话费补助),sum(出差补助),sum(应发工资) from (" & SQL(i) & ") group by 姓名"
    
28.         Sheets(i).Range("a65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL(i))
    
29.     Next
    
30.     cnn.Close
    
31.     Set cnn = Nothing
    
32.     Application.ScreenUpdating = True
    
33. End Sub
    

复制代码

zhaogang1960

本程序对同部门同姓名的汇总处理，数据源有点问题，同部门同姓名每月工作可能超过31天
请看附件
问题.rar (38.67 KB, 下载次数: 179)

2013-12-30 10:41 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim d As New Dictionary
   
3.   Dim cnn As New ADODB.Connection
   
4.   Dim rs As New ADODB.Recordset
   
5.   Dim ws As Worksheet
   
6.   Dim sql As String
   
7.   Dim mybook As String
   
8.   Dim mysheet As String
   
9.   Dim wbname As String
   
10.   Dim i As Integer
    
11.   
    
12.   Application.DisplayAlerts = False
    
13.   
    
14.   mybook = ThisWorkbook.FullName
    
15. 
    
16.   wbname = Dir(ThisWorkbook.Path & "\*.xls")
    
17.   
    
18.   Do While wbname <> ""
    
19.     If wbname <> "汇总.xls" Then
    
20.       d(wbname) = ""
    
21.     End If
    
22.     wbname = Dir()
    
23.   Loop
    
24.   
    
25.   With cnn
    
26.     .Provider = "microsoft.jet.oledb.4.0"
    
27.     .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
    
28.     .Open
    
29.   End With
    
30.   
    
31.   kk = d.Keys
    
32.   For Each ws In Worksheets
    
33.     sql = ""
    
34.     For i = 0 To UBound(kk)
    
35.       sql = sql & " union all select * from [Excel 8.0;database=" & ThisWorkbook.Path & "" & kk(i) & "].[" & ws.Name & "$a3:h]"
    
36.     Next
    
37.     sql = Mid(sql, 11)
    
38.     sql = "select 姓名,sum(出勤天数),sum(基本工资),sum(绩效工资),sum(各项保险),sum(话费补助),sum(出差补助),sum(应发工资) from (" & sql & ") where not isnull(姓名) and 姓名<>'合计' group by 姓名"
    
39.     rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
40.     With ws
    
41.       .UsedRange.Offset(3, 0).ClearContents
    
42.       .Range("a4").CopyFromRecordset rs
    
43.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
44.       .Cells(r + 1, 1) = "合计"
    
45.       .Cells(r + 1, 2).Resize(1, 7).FormulaR1C1 = "=SUM(R[" & 3 - r & "]C:R[-1]C)"
    
46.       .Range("a3:h" & r + 1).Borders.LineStyle = xlContinuous
    
47.     End With
    
48.     rs.Close
    
49.   Next
    
50.   cnn.Close
    
51.   Set rs = Nothing
    
52.   Set cnn = Nothing
    
53.   Application.DisplayAlerts = True
    
54. End Sub

复制代码

chxw68

详见附件。

qldd

zhaogang1960 发表于 2013-12-30 10:41
本程序对同部门同姓名的汇总处理，数据源有点问题，同部门同姓名每月工作可能超过31天
请看附件

谢谢赵老师的指教，完全符合要求，工作天数是原表中的结构，在最后汇总的时候我会去掉的，谢谢！！！

qldd

chxw68 发表于 2013-12-30 10:49
详见附件。

谢谢chxw68老师的帮助，完全符合要求，谢谢！！！

qldd

chxw68 发表于 2013-12-30 10:48

chxw68 老师，还有一个问题向您请教，就是想在最后加一个全公司（七个部门）汇总表，格式完全一样，按姓名汇总求和，请您有时间帮忙改一下，谢谢！！！