VBA批量搜索Excel文件Current Risk关键字提取数据汇总总表咨询

Sub 提取CurrentRisk数据汇总()
    Dim 主工作簿 As Workbook
    Dim 源工作簿 As Workbook
    Dim 源工作表 As Worksheet
    Dim 查找单元格 As Range
    Dim 首个查找地址 As String
    Dim 目标写入行 As Range
    Dim 待处理文件 As String
    
    ' --------------- 配置参数请根据实际情况修改 ---------------
    Const 主文件路径 As String = "C:\Users\phil\Desktop\Reports\MASTER\master file.xlsx" ' 主汇总文件路径
    Const 待处理文件夹 As String = "C:\Users\phil\Reports\MASTER\Data\" ' 存放待处理Excel的文件夹
    ' --------------------------------------------------------
    
    ' 打开主汇总工作簿
    Set 主工作簿 = Workbooks.Open(主文件路径)
    ' 初始化待处理文件遍历
    待处理文件 = Dir(待处理文件夹 & "*.xls*")
    
    Do While 待处理文件 <> ""
        ' 跳过主文件自身，避免重复读取
        If 待处理文件 <> 主工作簿.Name Then
            ' 打开待处理源文件
            Set 源工作簿 = Workbooks.Open(待处理文件夹 & 待处理文件, ReadOnly:=True)
            
            ' 遍历源文件所有工作表（如果只需要处理指定工作表可修改此处）
            For Each 源工作表 In 源工作簿.Worksheets
                ' 查找第一个匹配"Current Risk"的单元格
                Set 查找单元格 = 源工作表.Cells.Find(What:="Current Risk", LookIn:=xlValues, LookAt:=xlWhole)
                
                If Not 查找单元格 Is Nothing Then
                    首个查找地址 = 查找单元格.Address
                    ' 循环查找所有匹配项
                    Do
                        ' 处理合并单元格：合并单元格取值固定取左上角第一个单元格
                        If 查找单元格.MergeCells Then
                            Set 查找单元格 = 查找单元格.MergeArea.Cells(1, 1)
                        End If
                        
                        ' 定位主表下一行空行写入位置
                        Set 目标写入行 = 主工作簿.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                        
                        ' 按偏移要求写入数据
                        目标写入行.Value = 查找单元格.Offset(2, 2).Value ' 偏移(2,2)设备ID
                        目标写入行.Offset(0, 1).Value = 查找单元格.Offset(5, 3).Value ' 偏移(5,3)腐蚀速率
                        目标写入行.Offset(0, 2).Value = 查找单元格.Offset(5, 4).Value ' 偏移(5,4)剩余半衰期
                        目标写入行.Offset(0, 3).Value = 待处理文件 ' 可选：记录数据来源文件名方便追溯
                        
                        ' 查找下一个匹配项
                        Set 查找单元格 = 源工作表.Cells.FindNext(After:=查找单元格)
                    Loop While Not 查找单元格 Is Nothing And 查找单元格.Address <> 首个查找地址
                End If
            Next 源工作表
            
            ' 关闭源文件不保存
            源工作簿.Close SaveChanges:=False
        End If
        ' 读取下一个待处理文件
        待处理文件 = Dir
    Loop
    
    ' 自动保存主工作簿
    主工作簿.Save
    MsgBox "数据汇总完成！", vbInformation
End Sub

注意事项 #

• 代码开头的主文件路径和待处理文件夹参数需要根据实际存储路径修改
• 合并单元格处理逻辑已内置：检测到"Current Risk"为合并格式时，会自动取合并区域左上角单元格为基准计算偏移，符合按第1列计算的要求
• 如果只需处理指定名称的工作表，将遍历所有工作表的循环修改为指定工作表即可
• 运行前建议备份所有原始文件，避免误操作丢失数据

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