VBA遍历目录文件匹配搜索条件查找记录的技术咨询

功能说明 #

改造原有单工作表检索逻辑，实现指定目录下所有Excel文件的批量匹配检索，检索条件取自主工作簿指定列，匹配结果自动汇总到报告表。

完整实现代码 #

Option Explicit

Sub SearchMultipleTargetsAcrossFiles()
    Dim reportsheet As Worksheet    ' 结果输出的报告表
    Dim athletename As String
    Dim finalrow As Integer         ' 数据源最后一行行号
    Dim i As Integer                ' 数据源行循环计数器
    Dim t As Integer                ' 搜索条件行循环计数器
    Dim targetcount As Integer      ' 搜索条件总数
    Dim folderPath As String        ' 检索的目标目录路径
    Dim fileName As String          ' 遍历的文件名
    Dim wbData As Workbook          ' 遍历到的目标工作簿
    Dim wbDataSht As Worksheet      ' 目标工作簿中的数据源表
    
    ' 基础配置 可根据实际需求修改
    Set reportsheet = Sheet1 ' 结果输出的报告表
    Const DATA_COLUMN As Integer = 2 ' 匹配的数据源列号，默认B列
    Const COPY_COL_START As Integer = 1 ' 复制内容的起始列
    Const COPY_COL_END As Integer = 12 ' 复制内容的结束列
    
    ' 选择目标检索目录
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择需要检索的文件目录"
        If .Show <> -1 Then
            MsgBox "未选择目录，程序退出"
            Exit Sub
        End If
        folderPath = .SelectedItems(1) & "\"
    End With
    
    ' 清空报告表旧数据
    reportsheet.Range("A9:L1000").ClearContents
    ' 获取搜索条件总数
    targetcount = reportsheet.Cells(7, 2).End(xlUp).Row
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 遍历目录下所有Excel文件
    fileName = Dir(folderPath & "*.xls*")
    Do While fileName <> ""
        ' 跳过主工作簿自身
        If fileName <> ThisWorkbook.Name Then
            On Error Resume Next ' 跳过损坏/加密的无法打开的文件
            Set wbData = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
            On Error GoTo 0
            
            If Not wbData Is Nothing Then
                ' 取目标工作簿第一个工作表作为数据源，如需遍历所有工作表可在此处新增工作表循环
                Set wbDataSht = wbData.Sheets(1)
                finalrow = wbDataSht.Cells(wbDataSht.Rows.Count, 1).End(xlUp).Row
                
                ' 遍历所有搜索条件
                For t = 1 To targetcount
                    athletename = reportsheet.Cells(t, 2).Value
                    If athletename <> "" Then ' 跳过空的搜索条件
                        ' 遍历数据源行匹配
                        For i = 2 To finalrow
                            If wbDataSht.Cells(i, DATA_COLUMN) = athletename Then
                                wbDataSht.Range(wbDataSht.Cells(i, COPY_COL_START), wbDataSht.Cells(i, COPY_COL_END)).Copy
                                reportsheet.Range("A1000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
                            End If
                        Next i
                    End If
                Next t
                
                ' 关闭打开的工作簿不保存
                wbData.Close SaveChanges:=False
                Set wbData = Nothing
            End If
        End If
        fileName = Dir ' 读取下一个文件
    Loop
    
    ' 恢复系统默认设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    reportsheet.Select
    Range("B2").Select
    MsgBox "搜索完成"
End Sub

自定义调整说明 #

• 如需修改搜索条件所在位置，可调整targetcount = reportsheet.Cells(7, 2).End(xlUp).Row对应的行列参数
• 如需检索目标工作簿内所有工作表，可在打开工作簿后新增工作表遍历循环，替换当前取Sheets(1)的逻辑
• 如需修改匹配列、复制的列范围，可修改代码开头的常量配置参数

内容的提问来源于stack exchange，提问作者Const