VBA: 遍历文件抓取指定条件的数据

文章背景： 要查看某次考试成绩不及格的所有学生名单；假定按年级建文件夹，每个文件夹内有各班的考试成绩表（见下图）。需要遍历所有表格，然后对每行的学生成绩进行判断。

图1 文件框架

图2 表格示例

通过Excel VBA的UserForm控件来完成本文的任务。

各个控件内的代码如下所示：

Option Explicit
Option Base 1
'存储数据
Dim data(), flag As Integer
Private Sub CommandButton6_Click()
    '修改路径1的按钮
    With Application.FileDialog(filedialogtype:=msoFileDialogFolderPicker)
        .InitialFileName = "E:\工作\A校"             '设置起始目录
        .AllowMultiSelect = True                    '单选
        .Title = "请选新的文件夹路径1"               '设置对话框标题
        .Show                                       '显示对话框
        If .SelectedItems.Count > 0 Then
            TextBox1.Text = .SelectedItems(1)       '将选中的文件夹路径添加到文本框1
            MsgBox "没有选择目录！"
        End If
    End With
End Sub
Private Sub CommandButton7_Click()
    '修改路径2的按钮
    With Application.FileDialog(filedialogtype:=msoFileDialogFolderPicker)
        .InitialFileName = "E:\工作\B校"            '设置起始目录
        .AllowMultiSelect = True                    '单选
        .Title = "请选新的文件夹路径2"              '设置对话框标题
        .Show                                       '显示对话框
        If .SelectedItems.Count > 0 Then
            TextBox2.Text = .SelectedItems(1)       '将选中的文件夹路径添加到文本框1
            MsgBox "没有选择目录！"
        End If
    End With
End Sub
Private Sub CommandButton8_Click()
    '遍历查找
    Dim tarSheet As Worksheet, num As Integer, folder As String
    Dim time_ini As Date
    '0 准备工作
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    time_ini = Timer
    '1 清除原有数据
    Set tarSheet = ThisWorkbook.Worksheets("查找结果")
    num = tarSheet.Range("A65535").End(xlUp).Row
    If num > 1 Then
        tarSheet.Range("A2:E" & num).ClearContents
    End If
    flag = 0
    '2 遍历文件夹1
    folder = TextBox1.Text
    searchdata folder
    '3 遍历文件夹2
    folder = TextBox2.Text
    searchdata folder
    '4 数据汇总
    tarSheet.Range("A2").Resize(flag, 5) = Application.WorksheetFunction.Transpose(data)
    MsgBox "Done!  " & vbCrLf & vbCrLf & "用时：" & Format(Timer - time_ini, "0.0s")
    Erase data
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Exit Sub
End Sub
Sub searchdata(folder As String)
    '遍历子文件夹内的各个文件
    Dim fso As Object, fld As Object, subfld As Object, filename As String
    Dim aWB As Workbook, tempSheet As Worksheet, row_total As Integer
    Dim ii As Integer, jj As Integer
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(folder) Then             '判断文件夹是否存在
        Set fld = fso.GetFolder(folder)
        For Each subfld In fld.SubFolders                '遍历子文件夹
            filename = Dir(subfld & "\*.xlsx")
                Workbooks.Open subfld & "\" & filename
                Set aWB = ActiveWorkbook
                Set tempSheet = ActiveWorkbook.Worksheets(1)
                row_total = tempSheet.Range("A65535").End(xlUp).Row
                '遍历各行数据
                If row_total > 1 Then
                    For ii = 2 To row_total
                        If tempSheet.Cells(ii, 5) < 60 Then
                            flag = flag + 1
                            ReDim Preserve data(1 To 5, 1 To flag)
                            For jj = 1 To 5
                                data(jj, flag) = tempSheet.Cells(ii, jj)
                            Next jj
                        End If
                End If
                aWB.Close SaveChanges:=False
                filename = Dir
            Loop Until filename = ""
        MsgBox "文件夹的路径不存在，请确认！"
        Exit Sub
    End If
End Sub