根据条件在多个文件中提取相应数据，求助啊~

师小淳

我想把子文件的数据总汇到，总汇文件中，一个两个文件可以复制，但是如果文件很多的话就比较麻烦，各位高手有什么好方法么。
我附了附件。
附件中“总汇”文件如果选择身高，那么在红色底纹区域显示相应的数据，数据源在子文件里。
这里的起始年份是不同的，总汇中会设置所有文件里最早的一年，如果子文件中的年份没有相应数据的话，我希望在“总汇”中显示“”。
谢谢~~

zhaogang1960

ADO法速度很快，请参考：

1. Sub ADO加数组法()
   
2.     Dim Fso As Object, File As Object, cnn As Object, SQL$, i&, m&, c, arr, brr(), d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set Fso = CreateObject("scripting.filesystemobject")
   
5.     arr = Range("A1").CurrentRegion
   
6.     For i = 2 To UBound(arr, 2)
   
7.         d(arr(2, i)) = i
   
8.     Next
   
9.     myPath = ThisWorkbook.Path
   
10.     ReDim brr(1 To Fso.GetFolder(myPath).Files.Count, 1 To i - 1)
    
11.     Set cnn = CreateObject("ADODB.Connection")
    
12.     For Each File In Fso.GetFolder(myPath).Files
    
13.         If File.Name Like "*.xlsx" Then
    
14.             m = m + 1
    
15.             If m = 1 Then
    
16.                 cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & File
    
17.                 SQL = "SELECT * FROM [Sheet1$B2:I3]"
    
18.             Else
    
19.                 SQL = "SELECT * FROM [Excel 12.0;hdr=no;Database=" & File & "].[Sheet1$B2:I3]"
    
20.             End If
    
21.             arr = cnn.Execute(SQL).GetRows
    
22.             brr(m, 1) = Replace(File.Name, ".xlsx", "")
    
23.             For i = 0 To UBound(arr)
    
24.                 c = d(arr(i, 0))
    
25.                 If c <> "" Then brr(m, c) = arr(i, 1)
    
26.             Next
    
27.         End If
    
28.     Next
    
29.     ActiveSheet.UsedRange.Offset(2).ClearContents
    
30.     Range("a3").Resize(m, UBound(brr, 2)) = brr
    
31.     Set Fso = Nothing
    
32.     cnn.Close
    
33.     Set cnn = Nothing
    
34. End Sub
    

复制代码

zhaogang1960

请测试附件
根据条件在多个文件中提取相应数据.rar (28.15 KB, 下载次数: 255)

2015-10-15 17:07 上传

点击文件名下载附件

数据久久

1. Sub 复制粘贴()
   
2. Application.ScreenUpdating = False
   
3.     Dim fp$, obmapp As Object
   
4. Dim Xls, i As Long, lj As String
   
5.     Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)
   
6.         If Not obmapp Is Nothing Then
   
7.             fp = obmapp.Self.path & ""
   
8.         Else
   
9.              Exit Sub
   
10.         End If
    
11.    Xls = Dir(fp & "*.xls") '指定要遍历excel文件的路径及文件类型
    
12.    Do While Xls <> ""
    
13.    If Xls <> ThisWorkbook.path Then
    
14.       Set Xls = Workbooks.Open(fp & Xls) '打开excel文件,“\”要留着
    
15.         a = Application.WorksheetFunction.Match(Workbooks(1).Sheets(1).Cells(1, 1), Workbooks(2).Sheets(1).[a1:a5])
    
16.         
    
17.         ls = Workbooks(1).Sheets(1).Cells(3, 300).End(xlToLeft).Column + 1
    
18.         
    
19.         b = Application.WorksheetFunction.Match(Workbooks(2).Sheets(1).Cells(2, 2), Workbooks(1).Sheets(1).[a2:i2])
    
20.         
    
21.         c = Application.WorksheetFunction.Match(Mid(Workbooks(2).Name, 1, 2), Workbooks(1).Sheets(1).[a1:a5])
    
22.         
    
23.         Workbooks(2).Sheets(1).Range(Workbooks(2).Sheets(1).Cells(a, 2), Workbooks(2).Sheets(1).Cells(a, Workbooks(2).Sheets(1).Cells(a, 300).End(xlToLeft).Column)).Copy Workbooks(1).Sheets(1).Cells(c, b)
    
24.         
    
25.         
    
26.    End If
    
27.    Loop
    
28.    Set Xls = Nothing '释放变量内存
    
29.    
    
30. End Sub
    

复制代码

这个我写的，不过比不上上面的

师小淳

多谢zhaogang1960，之前也看到别的帖子您对ADO法的回复，最近开始对VBA感兴趣，多谢在学习的过程中有如此高手陪伴~~

师小淳

zhaogang1960 发表于 2015-10-15 17:07
请测试附件

多谢zhaogang1960，之前也看到别的帖子您对ADO法的回复，最近开始对VBA感兴趣，多谢在学习的过程中有如此高手陪伴~~

师小淳

数据久久 发表于 2015-10-15 17:12
这个我写的，不过比不上上面的

谢谢，可以对比一下，看看运行时间啊~~

LMY123

ADO加数组法

补充内容 (2019-1-1 18:31):
行单条件匹配_同夹_多薄_指定表_ADO加字典法，已入库。