文件夹遍历查询

三羧酸

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

三羧酸

有朋友用如下代码替我写了一段
Sub ado查询()  'by feiren228
    Dim fr$(), m%, p$, i&, j&, arr, brr, k, temp, kk
    Dim cnn As Object, rs As Object, sql$
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    p = ThisWorkbook.Path
    Call GetFiles(fr, m, p)
    Set cnn = CreateObject("Adodb.Connection")
    Set rs = CreateObject("adodb.recordset")
    If Application.Version * 1 <= 11 Then
        cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1;hdr=yes';Data Source=" & ThisWorkbook.FullName
    Else
        cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;imex=1;hdr=yes';Data Source=" & ThisWorkbook.FullName
    End If
    If m = 0 Then MsgBox "此文件夹下没有需要汇总的表格！": Exit Sub
    For i = 1 To UBound(fr)
        If i = 1 Then
            sql = "select 学号,姓名,性别,基础英语,泛读,总分,平均分 from [Excel 8.0;imex=1;Database=" & fr(i) & "].[sheet1$A3:I] where 学号 is not null"
            
        Else
            sql = sql & " union all select 学号,姓名,性别,基础英语,泛读,总分,平均分 from [Excel 8.0;imex=1;Database=" & fr(i) & "].[sheet1$A3:I] where 学号 is not null"
        End If
    Next i
    Set rs = cnn.Execute(sql)
    arr = rs.getrows
    With Sheets("汇总")
        r& = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
        brr = .Range("a1:g" & r)
        For i = 2 To UBound(brr)
            d(brr(i, 1)) = i
        Next
        For j = 1 To UBound(arr, 2)
            If d.exists(arr(0, j)) Then
                If Not d1.exists(arr(0, j)) Then
                    d1(arr(0, j)) = j
                Else
                    d1(arr(0, j)) = d1(arr(0, j)) & "," & j
                End If
               
            End If
        Next j
        For Each k In d1
            temp = Split(d1(k), ","): kk = UBound(temp) + 1
            If UBound(brr, 2) < kk * 4 + 3 Then ReDim Preserve brr(1 To UBound(brr), 1 To kk * 4 + 3)
            brr(d(k), 2) = arr(1, temp(0)): brr(d(k), 3) = arr(2, temp(0))
            For i = 0 To UBound(temp)
                For j = 4 To kk * 4 + 3 Step 4
                     brr(d(k), j) = arr(3, temp(0)): brr(d(k), j + 1) = arr(4, temp(0))
                     brr(d(k), j + 2) = arr(5, temp(0)): brr(d(k), j + 3) = arr(6, temp(0))
                Next j
            Next i
        Next
        .Range("b2:av65536,h1:av1").ClearContents
        .[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
        Range("D1:G1").AutoFill Destination:=.Cells(1, 4).Resize(1, UBound(brr, 2) - 3)
    End With
    rs.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub
Sub GetFiles(fr$(), m%, ByVal p$)
    'p为遍历的路径，fr为存储文件路径数组
    Dim SubFolder As Object
    Dim File As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(p)
    For Each File In Folder.Files
        If File.Name <> ThisWorkbook.Name Then
            If File.Name Like "*.xls" Or File.Name Like "*.xlsx" Then
                m = m + 1
                ReDim Preserve fr(1 To m)
                fr(m) = File
            End If
        End If
    Next
    For Each SubFolder In Folder.SubFolders
        Call GetFiles(fr, m, SubFolder.Path)
    Next
End Sub

三羧酸

结果只能将文件夹中的最后一个考试成绩反映出来。我需要把文件夹中每次的考试成绩都罗列出来，有几个文件夹，就有几次成绩，请高手帮忙再给改改！

三羧酸

请路过的高手替我看看吧！

三羧酸

再次拜请高手替我看看上面的程序，为什么不能显示其它的成绩

三羧酸

还没解决，再顶顶

蓝桥玄霜

1. Sub lqxs()
   
2. Dim fp$, Arr, i&, m&, nm$, rr%
   
3. Dim sh As Worksheet, j%, d
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Application.ScreenUpdating = False
   
6. Sheet1.Activate
   
7. [b2:z5000].Clear
   
8. Arr = [a1].CurrentRegion
   
9. For i = 2 To UBound(Arr)
   
10.     d(Arr(i, 1)) = i
    
11. Next
    
12. nm = ThisWorkbook.Name
    
13. fp = ThisWorkbook.Path & ""
    
14. Call searfile(fp, ".xls")
    
15. For i = 1 To UBound(Brr, 2)
    
16.     If Brr(2, i) <> nm Then
    
17.     With GetObject(Brr(1, i) & Brr(2, i))
    
18.         Arr1 = .Sheets(1).Range("A1").CurrentRegion: rr = rr + 1
    
19.         For j = 4 To UBound(Arr1)
    
20.             If d.exists(Arr1(j, 1)) Then
    
21.                 m = d(Arr1(j, 1))
    
22.                 If Cells(m, 2) = "" Then Cells(m, 2) = Arr1(j, 2): Cells(m, 3) = Arr1(j, 3)
    
23.                 Cells(m, 4 * rr) = Arr1(j, 4): Cells(m, 4 * rr + 1) = Arr1(j, 6): Cells(m, 4 * rr + 2) = Arr1(j, 8): Cells(m, 4 * rr + 3) = Arr1(j, 9)
    
24.             End If
    
25.         Next
    
26.         .Close False
    
27.     End With
    
28.     End If
    
29. Next
    
30. Application.ScreenUpdating = True
    
31. End Sub
    

复制代码

蓝桥玄霜

请见附件。

三羧酸

谢谢老师的帮助，可以用了！太感谢了！再定睛一看，原来是版主！{:soso_e142:}

三羧酸

版主，麻烦请再给看看，类似于201200637、201200643、201200639格式的学生完全可以正常查询，但是为什么类似于6075824的在职生学员查询不出来成绩了？