自动汇总文件夹内同结构表格的记录（请高手指导）

wdcswy

附件中个人记录表放在共享文件夹内，员工会每天更新两次。
我想实现不打开个人记录表的情况下，在汇总表格自动把各表格同一天（表格结构相同，即同行）的记录汇总在一个Sheet里面。
Excel统计.rar (71.69 KB, 下载次数: 32)

2012-7-27 10:51 上传

点击文件名下载附件
自动汇总文件夹内同结构表格的记录

zhaogang1960

有点难度，请测试：

1. Sub Macro1()
   
2.     Dim cnn As Object, SQL$, s$, MyPath$, MyFile$, m&, n&, t$, sh As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     For Each sh In Sheets
   
6.         sh.UsedRange.Offset(2).ClearContents
   
7.     Next
   
8.     Set cnn = CreateObject("ADODB.Connection")
   
9.     MyPath = ThisWorkbook.Path & "\数据" '路径自己修改
   
10.     MyFile = Dir(MyPath & "*.xlsx")
    
11.     Do While MyFile <> ""
    
12.         n = n + 1
    
13.         If n = 1 Then
    
14.             cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & MyPath & MyFile
    
15.         Else
    
16.             t = "[Excel 12.0;Database=" & MyPath & MyFile & "]."
    
17.         End If
    
18.         m = m + 1
    
19.         If m > 49 Then
    
20.             For Each sh In Sheets
    
21.                 s = "select [姓名],[日计划（8:00）],[日总结（17:00）],[备注] from (" & SQL & ") where 日期=#" & sh.[e1] & "#"
    
22.                 sh.Cells(Rows.Count, 2).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(s)
    
23.             Next
    
24.             m = 1
    
25.             SQL = ""
    
26.         End If
    
27.         If Len(SQL) Then SQL = SQL & " union all "
    
28.         SQL = SQL & "select * from " & t & "[个人工作记录表$b2:f]"
    
29.         MyFile = Dir()
    
30.     Loop
    
31.     If Len(SQL) Then
    
32.         For Each sh In Sheets
    
33.             s = "select [姓名],[日计划（8:00）],[日总结（17:00）],[备注] from (" & SQL & ") where 日期=#" & sh.[e1] & "#"
    
34.             sh.Cells(Rows.Count, 2).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(s)
    
35.         Next
    
36.     End If
    
37.     cnn.Close
    
38.     Set cnn = Nothing
    
39.     Application.ScreenUpdating = True
    
40. End Sub
    

复制代码

zhaogang1960

为了简化程序，请手工创建所有日期的工作表（8.1、8.2、8.3、8.4……），程序根据每个工作表的E1单元格日期来确定查询的内容
请自己修改路径，请看附件
Excel统计.rar (89.15 KB, 下载次数: 85)

2012-7-27 11:23 上传

点击文件名下载附件

wdcswy

{:soso_e179:}
版主真厉害，简短的代码就把我的问题解决了。
代码这块基本不懂，所以想请教一下：
1、序号那一列能否生成一下，不设清空我提前加上也行；
2、姓名一列可不可以我提前在某位置列出顺序，然后按顺利列出；

wdcswy

zhaogang1960 发表于 2012-7-27 11:23
为了简化程序，请手工创建所有日期的工作表（8.1、8.2、8.3、8.4……），程序根据每个工作表的E1单元格日期 ...

版主真厉害，简短的代码就把我的问题解决了。
代码这块基本不懂，所以想请教一下：
1、序号那一列能否生成一下，不设清空我提前加上也行；
2、姓名一列可不可以我提前在某位置列出顺序，然后按顺利列出。

zhaogang1960

wdcswy 发表于 2012-7-27 13:38
版主真厉害，简短的代码就把我的问题解决了。
代码这块基本不懂，所以想请教一下：
1、序号那一列能否 ...

没有问题，下午有空再写

wdcswy

zhaogang1960 发表于 2012-7-27 13:39
没有问题，下午有空再写

版主，您好！
请问可不可以调整成只更新当前这个Sheet，现在好像是所有Sheet都更新，我有个固定格式的打印页（通过公式链接过去的内容）想放在同一个文件里。

麻烦您指导一下，谢谢！

zhaogang1960

wdcswy 发表于 2012-7-27 15:28
版主，您好！
请问可不可以调整成只更新当前这个Sheet，现在好像是所有Sheet都更新，我有个固定格式的打 ...

请上传附件模拟一下效果

wdcswy

zhaogang1960 发表于 2012-7-27 15:42
请上传附件模拟一下效果

版主，您好！

请查看附件，为了防止不小心把工作公式搞乱，我开始的时候把打印页做了保护工作表（密码为空），单按钮的时候总是提示单元格被保护，后来我把打印页撤销了保护，提示日期有误，所有Sheet中第3行以后的内容被清空了。
Excel统计A.rar (124.86 KB, 下载次数: 17)

2012-7-27 16:13 上传

点击文件名下载附件

zhaogang1960

1. Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'ThisWorkbook代码区,除了"打印页"之外的各表"$E$1"变动时自动响应
   
2.     If Sh.Name = "打印页" Then Exit Sub
   
3.     If Target.Address <> "$E$1" Then Exit Sub
   
4.     Dim cnn As Object, SQL$, s$, MyPath$, MyFile$, m&, n&, t$
   
5.     Dim Mydate As Date, d As Object, arr, brr(), i&, j&, r
   
6.     Application.ScreenUpdating = False
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Mydate = Target.Value
   
9.     arr = Range("b3:b" & Range("b" & Rows.Count).End(xlUp).Row)
   
10.     ReDim brr(1 To UBound(arr), 2 To 4)
    
11.     For i = 1 To UBound(arr)
    
12.         d(arr(i, 1)) = i
    
13.     Next
    
14.     On Error Resume Next
    
15.     Set cnn = CreateObject("ADODB.Connection")
    
16.     MyPath = ThisWorkbook.Path & "\数据" '路径自己修改
    
17.     MyFile = Dir(MyPath & "*.xlsx")
    
18.     Do While MyFile <> ""
    
19.         n = n + 1
    
20.         If n = 1 Then
    
21.             cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & MyPath & MyFile
    
22.         Else
    
23.             t = "[Excel 12.0;Database=" & MyPath & MyFile & "]."
    
24.         End If
    
25.         m = m + 1
    
26.         If m > 49 Then
    
27.             arr = cnn.Execute(SQL).getrows
    
28.             For i = 0 To UBound(arr, 2)
    
29.                 r = d(arr(1, i))
    
30.                 If r <> "" Then
    
31.                     For j = 2 To 4
    
32.                         brr(r, j) = arr(j, i)
    
33.                     Next
    
34.                 End If
    
35.             Next
    
36.             m = 1
    
37.             SQL = ""
    
38.         End If
    
39.         If Len(SQL) Then SQL = SQL & " union all "
    
40.         SQL = SQL & "select * from " & t & "[个人工作记录表$b2:f] where 日期=#" & Mydate & "#"
    
41.         MyFile = Dir()
    
42.     Loop
    
43.     If Len(SQL) Then
    
44.         arr = cnn.Execute(SQL).getrows
    
45.         For i = 0 To UBound(arr, 2)
    
46.             r = d(arr(1, i))
    
47.             If r <> "" Then
    
48.                 For j = 2 To 4
    
49.                     brr(r, j) = arr(j, i)
    
50.                 Next
    
51.             End If
    
52.         Next
    
53.     End If
    
54.     ActiveSheet.UsedRange.Offset(2, 2).ClearContents
    
55.     [c3].Resize(UBound(brr), 3) = brr
    
56.     cnn.Close
    
57.     Set cnn = Nothing
    
58.     Application.ScreenUpdating = True
    
59. End Sub
    

复制代码