EXCEL VBA 实现 同一文件夹下相同格式的数据汇总到同一文件下

xhwuya

求助大神：

附件中的6个excel文件为不同部门的考勤，格式完全相同。

现在想把这些表格的B——M列汇总到同一个文件下（附件中的汇总），并且这个汇总文件放在其他月份的文件夹下也可以总动汇总叠加数据。

详情请见附件。非常感谢~

zhaogang1960

请参考：

1. Sub ADO法()
   
2.     Dim cnn As Object, SQL$, MyFile$, m%
   
3.     Application.ScreenUpdating = False
   
4.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
5.     Set cnn = CreateObject("adodb.connection")
   
6.     MyFile = Dir(ThisWorkbook.Path & "\*.xls")
   
7.     While MyFile <> ""
   
8.         If MyFile <> ThisWorkbook.Name Then
   
9.             m = m + 1
   
10.             If m = 1 Then
    
11.                 cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='excel 12.0;hdr=no';Data Source=" & ThisWorkbook.Path & "" & MyFile
    
12.                 SQL = "select * from [考勤$B3:M]"
    
13.                 Range("A2").CopyFromRecordset cnn.Execute(SQL)
    
14.             Else
    
15.                 SQL = "select * from [Excel 12.0;hdr=no;Database=" & ThisWorkbook.Path & "" & MyFile & "].[考勤$B3:M]"
    
16.                 Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
17.             End If
    
18.         End If
    
19.         MyFile = Dir()
    
20.     Wend
    
21.     cnn.Close
    
22.     Set cnn = Nothing
    
23.     Application.ScreenUpdating = True
    
24. End Sub
    

复制代码

zhaogang1960

请测试附件
7月考勤.rar (117.42 KB, 下载次数: 95)

2015-7-20 16:47 上传

点击文件名下载附件

xhwuya

zhaogang1960 发表于 2015-7-20 16:47
请测试附件

从今天起向大神看起

xhwuya

zhaogang1960 发表于 2015-7-20 16:46
请参考：

大叔，如果我想要实现：按第二次按钮时，汇总表又遍历一遍文件夹，又在汇总表后面汇总一次，怎么实现？我的目的是，把这个汇总表放在其他月份的文件夹内，可以自动在后面累加数据其他月份的数据而不会抹去先前的数据。

zhaogang1960

xhwuya 发表于 2015-7-21 09:26
大叔，如果我想要实现：按第二次按钮时，汇总表又遍历一遍文件夹，又在汇总表后面汇总一次，怎么实现？我 ...

删除这一句:
ActiveSheet.UsedRange.Offset(1).ClearContents

xhwuya

zhaogang1960 发表于 2015-7-21 09:38
删除这一句:
ActiveSheet.UsedRange.Offset(1).ClearContents

大叔，按照你的提示改成这样了。见附件，测试之后有误。麻烦你帮我看看，谢谢

zhaogang1960

xhwuya 发表于 2015-7-21 10:01
大叔，按照你的提示改成这样了。见附件，测试之后有误。麻烦你帮我看看，谢谢

1. Sub ADO法()
   
2.     Dim cnn As Object, SQL$, MyFile$, m%
   
3.     Application.ScreenUpdating = False
   
4.     Set cnn = CreateObject("adodb.connection")
   
5.     MyFile = Dir(ThisWorkbook.Path & "\*.xls")
   
6.     While MyFile <> ""
   
7.         If MyFile <> ThisWorkbook.Name Then
   
8.             m = m + 1
   
9.             If m = 1 Then
   
10.                 cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='excel 12.0;hdr=no';Data Source=" & ThisWorkbook.Path & "" & MyFile
    
11.                 SQL = "select * from [考勤$B3:M]"
    
12.             Else
    
13.                 SQL = "select * from [Excel 12.0;hdr=no;Database=" & ThisWorkbook.Path & "" & MyFile & "].[考勤$B3:M]"
    
14.             End If
    
15.             Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
16.         End If
    
17.         MyFile = Dir()
    
18.     Wend
    
19.     cnn.Close
    
20.     Set cnn = Nothing
    
21.     Application.ScreenUpdating = True
    
22. End Sub
    

复制代码

xhwuya

zhaogang1960 发表于 2015-7-21 10:07

大神大叔。我又来找你了。看了你给我的代码，我自己开始好好学习VBA，看到了ADO（） Range（）方法。
现在问题来了：程序运行后。显示“外部表不是预期的格式”错误，但是可以调出来Ａ、Ｂ、Ｃ、Ｄ班的数据，调不出其他三个表格的。

xhwuya

zhaogang1960 发表于 2015-7-21 09:38
删除这一句:
ActiveSheet.UsedRange.Offset(1).ClearContents

大叔，快出来。