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

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
            
        Else
        
            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
            
        Else
        
            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")
            
            Do
                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
                    
                    Next
                    
                End If
                
                aWB.Close SaveChanges:=False
                
                filename = Dir
                
            Loop Until filename = ""
        
        Next
        
    Else
    
        MsgBox "文件夹的路径不存在，请确认！"
        
        Exit Sub
    
    End If

End Sub

Private Sub UserForm_Initialize()

    TextBox1.Text = "E:\工作\A校"
    TextBox2.Text = "E:\工作\B校"

End Sub