不同文件夹下相同类型工作表数据汇总

beleqing

zhaogang1960 发表于 2013-12-29 23:32
修改如下：

谢谢大版主

{:soso_e134:}{:soso_e134:}{:soso_e134:}

大部分都看不懂，可否帮忙写几句注释提示下给我这个零基础的！{:soso_e117:}

多谢了！

zhaogang1960

beleqing 发表于 2013-12-30 09:27
谢谢大版主

这个程序涉及知识比较多，没有基础是看不懂的，建议学习一个VBA知识

1. Sub 宏1()
   
2.     Dim cnn As Object, SQL$, Mypath$, MyFile$, m&, n&, t$
   
3.     Dim Fso As Object, arrf$(), mf&, sFileType$, j&
   
4.     Application.ScreenUpdating = False
   
5.     sFileType = "*.xlsx"
   
6.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
7.     Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arrf, mf)
   
8.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
9.     Set cnn = CreateObject("ADODB.Connection")
   
10.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & arrf(1) '连接第一个文件
    
11.    
    
12.     For j = 1 To mf '逐个文件
    
13.         m = m + 1
    
14.         If m > 49 Then '49个工作表复制一次数据
    
15.             Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL) '复制数据
    
16.             m = 1
    
17.             SQL = ""
    
18.         End If
    
19.         If Len(SQL) Then SQL = SQL & " union all "
    
20.         SQL = SQL & "select * from [Excel 12.0;Database=" & arrf(j) & "].[Sheet1$]" '联合查询语句
    
21.     Next
    
22.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL) '最后再检查一个是否还有数据
    
23.     cnn.Close
    
24.     Set cnn = Nothing
    
25.     Set Fso = Nothing
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    
28. 
    
29. Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&) '搜索所有子文件夹中所有文件子程序
    
30.     Dim Folder As Object
    
31.     Dim SubFolder As Object
    
32.     Dim File As Object
    
33.     Set Folder = Fso.GetFolder(sPath)
    
34.     If sPath <> ThisWorkbook.Path Then
    
35.         For Each File In Folder.Files
    
36.             If File.Name Like sFileType Then
    
37.                 mf = mf + 1
    
38.                 ReDim Preserve arrf(1 To mf)
    
39.                 arrf(mf) = sPath & "" & File.Name
    
40.             End If
    
41.         Next
    
42.     End If
    
43.     If Folder.SubFolders.Count > 0 Then
    
44.         For Each SubFolder In Folder.SubFolders
    
45.             Call GetFiles(SubFolder.Path, sFileType, Fso, arrf, mf)
    
46.         Next
    
47.     End If
    
48.     Set Folder = Nothing
    
49.     Set File = Nothing
    
50.     Set SubFolder = Nothing
    
51. End Sub

复制代码

beleqing

zhaogang1960 发表于 2013-12-30 10:10
这个程序涉及知识比较多，没有基础是看不懂的，建议学习一个VBA知识

OK, thank you very much!

I will need a bit of time to read it through.

Thank you for you help!!

beleqing

zhaogang1960 发表于 2013-12-30 10:10
这个程序涉及知识比较多，没有基础是看不懂的，建议学习一个VBA知识

大版主，可否帮忙大概列一下，我想明白这些代码的话需要哪些基础知识？需要什么书？

我在本帖子举的例子是简单的自己编的，我们实际工作里远比这个复杂，但是道理是一样的。

我想学习下，但是学太多别的知识的话时间又不够。谢谢你！

zhaogang1960

beleqing 发表于 2013-12-30 16:41
大版主，可否帮忙大概列一下，我想明白这些代码的话需要哪些基础知识？需要什么书？

我在本帖子举的例 ...

这个题目不复杂，仅复制数据，不需要修改
但要确保：
一、保证数据源工作表名都是Sheet1
二、数据源格式不要再发生变化

beleqing

zhaogang1960 发表于 2013-12-30 16:52
这个题目不复杂，仅复制数据，不需要修改
但要确保：
一、保证数据源工作表名都是Sheet1

大版主，是不是可以这样想，要能灵活应用这些代码，就差不多需要学习所有的VBA知识？

zhaogang1960

beleqing 发表于 2013-12-31 08:46
大版主，是不是可以这样想，要能灵活应用这些代码，就差不多需要学习所有的VBA知识？

不需要，涉及知识点如下：
1、Fso文件系统对象
2、ADO数据库语言
3、数组知识

beleqing

zhaogang1960 发表于 2013-12-31 11:22
不需要，涉及知识点如下：
1、Fso文件系统对象
2、ADO数据库语言

谢谢！我学习一下你发的知识点！

beleqing

zhaogang1960 发表于 2013-12-31 11:22
不需要，涉及知识点如下：
1、Fso文件系统对象
2、ADO数据库语言

SQL = SQL & "select * from [Excel 12.0;Database=" & arrf(j) & "].[Sheet1$]"

高手请问下哈，你这条语句的功能是合并所有excel的sheet1的内容

如果改为合并所有excel的工作簿‘汇总’的A1:C7怎么修改？

谢谢！