Excel VBA批量搜索文件夹文件关键词并提取指定单元格数据求助

问题描述 #

我有一个包含大量Excel文件的文件夹，需按预设关键词搜索文件内容。找到含关键词的单元格后，要提取对应表格中“Approved”列最后一行的数据（如含“stone”的单元格对应值14.9），并将结果汇总到新建的summary工作表中。目前已适配VBA代码完成大部分功能，但无法获取汇总表G列（Amount列）的对应值，代码中需修改的部分标记为“??????”，使用MS Office 365，请求协助修改代码。

现有代码 #

Public Sub searchText()
    Dim MyFSO As FileSystemObject
    Dim MyFolder As folder
    Dim MySubfolder As folder
    Dim wb As Object
    Dim ws As Worksheet

    searchList = Array("stone", "somthng")    'define the list of text you want to search, case insensitive
    
    Set MyFSO = New FileSystemObject
    folderPath = "D:\Inert\М-29.xlsm" 'define the path of the folder that contains the workbooks
    Set folder = MyFSO.GetFolder(folderPath)
    Dim thisWbWs, newWS As Worksheet
    
    'Create summary worksheet if not exist
    For Each thisWbWs In ActiveWorkbook.Worksheets
        If wsExists("summary") Then
            counter = 1
        End If
    Next thisWbWs
    
    If counter = 0 Then
        Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
        With newWS
            .Name = "summary"
            .Range("A1").Value = "Keyword"
            .Range("B1").Value = "Workbook"
            .Range("C1").Value = "Worksheet"
            .Range("D1").Value = "Address"
            .Range("E1").Value = "Found cell content"
            .Range("F1").Value = "Measure"
            .Range("G1").Value = "Amount"
        End With
    End If

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With
        
    'Check each workbook in main folder
    For Each wb In folder.Files
        If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
            Set masterWB = Workbooks.Open(wb)
            For Each ws In masterWB.Worksheets
              For Each Rng In ws.UsedRange
                For Each i In searchList
                    If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then   'vbTextCompare means case insensitive.
                        nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
                        
                        With ThisWorkbook.Sheets("summary")
                            .Range("A" & nextRow).Value = i
                            .Range("B" & nextRow).Value = Application.ActiveWorkbook.FullName
                            .Range("C" & nextRow).Value = ws.Name
                            .Range("D" & nextRow).Value = Rng.Address
                            .Range("E" & nextRow).Value = Rng.Value
                            .Range("F" & nextRow).Value = Rng.Offset(1).Value
                            .Range("G" & nextRow).Value = ??????????????
                        End With
                    End If
                Next i
              Next Rng
            Next ws
            ActiveWorkbook.Close True
        End If
    Next
    
    'Check each workbook in sub folders
    For Each subfolder In folder.SubFolders
        For Each wb In subfolder.Files
            If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
                Set masterWB = Workbooks.Open(wb)
                For Each ws In masterWB.Worksheets
                  For Each Rng In ws.UsedRange
                    For Each i In searchList
                        If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then
                            nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
                            With ThisWorkbook.Sheets("summary")
                                .Range("A" & nextRow).Value = i
                                .Range("B" & nextRow).Value = Application.ActiveWorkbook.FullName
                                .Range("C" & nextRow).Value = ws.Name
                                .Range("D" & nextRow).Value = Rng.Address
                                .Range("E" & nextRow).Value = Rng.Value
                                .Range("F" & nextRow).Value = Rng.Offset(1).Value
                .Range("G" & nextRow).Value = ??????????????
                            End With
                        End If
                    Next i
                  Next Rng
                Next ws
                ActiveWorkbook.Close True
            End If
        Next
    Next
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With
    
    ThisWorkbook.Sheets("summary").Cells.Select
    ThisWorkbook.Sheets("summary").Cells.EntireColumn.AutoFit
    ThisWorkbook.Sheets("summary").Range("A1").Select
    
End Sub 

Function wsExists(wksName As String) As Boolean
    On Error Resume Next
    wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
    On Error GoTo 0
End Function

修改后的完整代码 #

Public Sub searchText()
    Dim MyFSO As FileSystemObject
    Dim MyFolder As folder
    Dim MySubfolder As folder
    Dim wb As Object
    Dim ws As Worksheet
    Dim searchList As Variant
    Dim folderPath As String
    Dim counter As Integer
    Dim masterWB As Workbook
    Dim nextRow As Long
    Dim Rng As Range
    Dim i As Variant

    searchList = Array("stone", "somthng")    '定义要搜索的关键词列表，不区分大小写
    
    Set MyFSO = New FileSystemObject
    folderPath = "D:\Inert" '修正为文件夹路径（原代码误写为文件路径）
    Set MyFolder = MyFSO.GetFolder(folderPath)
    Dim thisWbWs As Worksheet, newWS As Worksheet
    
    '初始化counter
    counter = 0
    '检查summary工作表是否存在
    If wsExists("summary") Then
        counter = 1
    End If
    
    If counter = 0 Then
        Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
        With newWS
            .Name = "summary"
            .Range("A1").Value = "Keyword"
            .Range("B1").Value = "Workbook"
            .Range("C1").Value = "Worksheet"
            .Range("D1").Value = "Address"
            .Range("E1").Value = "Found cell content"
            .Range("F1").Value = "Measure"
            .Range("G1").Value = "Amount"
        End With
    End If

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With
        
    '检查主文件夹中的每个工作簿
    For Each wb In MyFolder.Files
        If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
            Set masterWB = Workbooks.Open(wb)
            For Each ws In masterWB.Worksheets
              For Each Rng In ws.UsedRange
                For Each i In searchList
                    If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then   'vbTextCompare表示不区分大小写
                        nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
                        
                        With ThisWorkbook.Sheets("summary")
                            .Range("A" & nextRow).Value = i
                            .Range("B" & nextRow).Value = masterWB.FullName
                            .Range("C" & nextRow).Value = ws.Name
                            .Range("D" & nextRow).Value = Rng.Address
                            .Range("E" & nextRow).Value = Rng.Value
                            .Range("F" & nextRow).Value = Rng.Offset(1).Value
                            '提取Approved列最后一行数据
                            .Range("G" & nextRow).Value = GetLastApprovedValue(ws)
                        End With
                    End If
                Next i
              Next Rng
            Next ws
            masterWB.Close True
        End If
    Next
    
    '检查子文件夹中的每个工作簿
    For Each MySubfolder In MyFolder.SubFolders
        For Each wb In MySubfolder.Files
            If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
                Set masterWB = Workbooks.Open(wb)
                For Each ws In masterWB.Worksheets
                  For Each Rng In ws.UsedRange
                    For Each i In searchList
                        If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then
                            nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
                            With ThisWorkbook.Sheets("summary")
                                .Range("A" & nextRow).Value = i
                                .Range("B" & nextRow).Value = masterWB.FullName
                                .Range("C" & nextRow).Value = ws.Name
                                .Range("D" & nextRow).Value = Rng.Address
                                .Range("E" & nextRow).Value = Rng.Value
                                .Range("F" & nextRow).Value = Rng.Offset(1).Value
                                '提取Approved列最后一行数据
                                .Range("G" & nextRow).Value = GetLastApprovedValue(ws)
                            End With
                        End If
                    Next i
                  Next Rng
                Next ws
                masterWB.Close True
            End If
        Next
    Next
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With
    
    ThisWorkbook.Sheets("summary").Cells.EntireColumn.AutoFit
    ThisWorkbook.Sheets("summary").Range("A1").Select
    
End Sub 

Function wsExists(wksName As String) As Boolean
    On Error Resume Next
    wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
    On Error GoTo 0
End Function

'辅助函数：获取指定工作表中Approved列的最后一行有效值
Function GetLastApprovedValue(ws As Worksheet) As Variant
    Dim approvedCol As Range
    Dim lastRow As Long
    
    '查找Approved列（表头在第一行）
    Set approvedCol = ws.Rows(1).Find(What:="Approved", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    
    If Not approvedCol Is Nothing Then
        '获取该列最后一行的行号
        lastRow = ws.Cells(ws.Rows.Count, approvedCol.Column).End(xlUp).Row
        '返回最后一行的值
        GetLastApprovedValue = ws.Cells(lastRow, approvedCol.Column).Value
    Else
        '如果未找到Approved列，返回空值
        GetLastApprovedValue = ""
    End If
End Function

关键修改说明 #

1. 修正路径错误：原代码中folderPath误写为文件路径，改为实际的文件夹路径（如D:\Inert）
2. 补全变量声明：添加了未定义的变量声明（如counter、masterWB等），避免隐式变量带来的问题
3. 替换占位代码：将两处??????????????替换为调用辅助函数GetLastApprovedValue(ws)，实现提取"Approved"列最后一行数据的功能
4. 优化工作簿引用：将Application.ActiveWorkbook.FullName改为masterWB.FullName，避免激活状态变化导致的错误
5. 添加辅助函数：新增GetLastApprovedValue函数，负责在指定工作表中查找"Approved"列，并返回该列最后一行的有效值；如果未找到该列则返回空值

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