学生成绩文件夹遍历查询

三羧酸

各位老师们，在下不会编写VBA程序。但是，工作中总会出现这方面的需求，现在把这个需求提出来，敬请高手帮忙解决！
我的问题是：
学生在学习期间，不同时间段产生了一些学习成绩。被我用同样的文件名储存在不同子文件加下。现在我想查询一些学生的成绩变化！
要实现的目标：
在上传的附件中，有一个学生成绩查询表.xls，这个表的第一列是随时需要查询的学生学号（后期可能随时更改），根据这个待查询列，将文件夹中所有的子文件夹中相应的科目的成绩汇总到学生成绩查询表。
这里子文件夹的个数还会增加，在下图中因为上传的附加中有5个子文件夹，所以下表中要出现5个不同的基础英语、泛读、总分、平均分的成绩。

待查学生学号

姓名

性别

基础英语

泛读

总分

平均分

基础英语

泛读

总分

平均分

基础英语

泛读

总分

平均分

基础英语

泛读

总分

平均分

基础英语

泛读

总分

平均分

201200637

201200643

201200639

201200644

201200636

201200642

201200640

201200634

201200641

201200645

201200638

201200635

三羧酸

实现上述问题的好处是，能对平时考察的成绩，进行汇总。观察学生学习的变化，这个很有意义，拜请高手替我实现！

三羧酸

请高手给看看吧！
{:soso_e183:}

三羧酸

只有一个人下载了，我再顶顶

三羧酸

下来了，我在顶上，请现在到了的高手给看看吧！谢谢！

feiren228

三羧酸 发表于 2015-9-24 16:26
下来了，我在顶上，请现在到了的高手给看看吧！谢谢！

请测试》》

1. Sub ado查询()  'by feiren228
   
2.     Dim fr$(), m%, p$, i&, j&, arr, brr, k, temp, kk
   
3.     Dim cnn As Object, rs As Object, sql$
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     p = ThisWorkbook.Path
   
7.     Call GetFiles(fr, m, p)
   
8.     Set cnn = CreateObject("Adodb.Connection")
   
9.     Set rs = CreateObject("adodb.recordset")
   
10.     If Application.Version * 1 <= 11 Then
    
11.         cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1;hdr=yes';Data Source=" & ThisWorkbook.FullName
    
12.     Else
    
13.         cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;imex=1;hdr=yes';Data Source=" & ThisWorkbook.FullName
    
14.     End If
    
15.     If m = 0 Then MsgBox "此文件夹下没有需要汇总的表格！": Exit Sub
    
16.     For i = 1 To UBound(fr)
    
17.         If i = 1 Then
    
18.             sql = "select 学号,姓名,性别,基础英语,泛读,总分,平均分 from [Excel 8.0;imex=1;Database=" & fr(i) & "].[sheet1$A3:I] where 学号 is not null"
    
19.             
    
20.         Else
    
21.             sql = sql & " union all select 学号,姓名,性别,基础英语,泛读,总分,平均分 from [Excel 8.0;imex=1;Database=" & fr(i) & "].[sheet1$A3:I] where 学号 is not null"
    
22.         End If
    
23.     Next i
    
24.     Set rs = cnn.Execute(sql)
    
25.     arr = rs.getrows
    
26.     With Sheets("汇总")
    
27.         r& = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
    
28.         brr = .Range("a1:g" & r)
    
29.         For i = 2 To UBound(brr)
    
30.             d(brr(i, 1)) = i
    
31.         Next
    
32.         For j = 1 To UBound(arr, 2)
    
33.             If d.exists(arr(0, j)) Then
    
34.                 If Not d1.exists(arr(0, j)) Then
    
35.                     d1(arr(0, j)) = j
    
36.                 Else
    
37.                     d1(arr(0, j)) = d1(arr(0, j)) & "," & j
    
38.                 End If
    
39.                
    
40.             End If
    
41.         Next j
    
42.         For Each k In d1
    
43.             temp = Split(d1(k), ","): kk = UBound(temp) + 1
    
44.             If UBound(brr, 2) < kk * 4 + 3 Then ReDim Preserve brr(1 To UBound(brr), 1 To kk * 4 + 3)
    
45.             brr(d(k), 2) = arr(1, temp(0)): brr(d(k), 3) = arr(2, temp(0))
    
46.             For i = 0 To UBound(temp)
    
47.                 For j = 4 To kk * 4 + 3 Step 4
    
48.                      brr(d(k), j) = arr(3, temp(0)): brr(d(k), j + 1) = arr(4, temp(0))
    
49.                      brr(d(k), j + 2) = arr(5, temp(0)): brr(d(k), j + 3) = arr(6, temp(0))
    
50.                 Next j
    
51.             Next i
    
52.         Next
    
53.         .Range("b2:av65536,h1:av1").ClearContents
    
54.         .[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
    
55.         Range("D1:G1").AutoFill Destination:=.Cells(1, 4).Resize(1, UBound(brr, 2) - 3)
    
56.     End With
    
57.     rs.Close
    
58.     Set rs = Nothing
    
59.     Set cnn = Nothing
    
60. End Sub
    
61. Sub GetFiles(fr$(), m%, ByVal p$)
    
62.     'p为遍历的路径，fr为存储文件路径数组
    
63.     Dim SubFolder As Object
    
64.     Dim File As Object
    
65.     Set FSO = CreateObject("Scripting.FileSystemObject")
    
66.     Set Folder = FSO.GetFolder(p)
    
67.     For Each File In Folder.Files
    
68.         If File.Name <> ThisWorkbook.Name Then
    
69.             If File.Name Like "*.xls" Or File.Name Like "*.xlsx" Then
    
70.                 m = m + 1
    
71.                 ReDim Preserve fr(1 To m)
    
72.                 fr(m) = File
    
73.             End If
    
74.         End If
    
75.     Next
    
76.     For Each SubFolder In Folder.SubFolders
    
77.         Call GetFiles(fr, m, SubFolder.Path)
    
78.     Next
    
79. End Sub
    

复制代码

feiren228

附件。。
2015级成绩表-test.zip (55.48 KB, 下载次数: 48)

2015-9-24 16:40 上传

点击文件名下载附件

三羧酸

怎么提示“找不到可安装的 isam”

三羧酸

“cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;imex=1;hdr=yes';Data Source=" & ThisWorkbook.FullName”被显示为黄色

feiren228

三羧酸 发表于 2015-9-24 16:54
“cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;imex=1;hdr=yes';Data S ...

excel 版本多少？