VBA：按照Excel工作表中的名称列自动汇总多个工作薄中对应sheet中所需要的数据

需求如下：

1. B列为产品名为合并单元格，C列为供应商名，G、H列为金额数据；
2. 数据源放在同一个文件夹内，B列产品名来源于工作薄名称中间的字符串，C列供应商名来源于工作薄中的sheet名；
3. G、H列金额数据来源于工作薄中sheet中固定单元格P25:Q25的数值；
4. 根据B列产品名自动打开对应的工作薄，并按照C列供应商名对应的sheet，把P25:Q25的数据自动复制到G、H列；

VBA执行效果视频

数据自动汇总

Sub GetDataFromSourceWorkbooks()
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim currentSheetName As String
    Dim sourceFolder As String
    Dim productColumn As String
    Dim supplierColumn As String
    Dim amount1Column As String
    Dim amount2Column As String
    Dim cell As Range
    Dim product As String
    Dim supplier As String
    Dim sourceFileName As String
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim amount1 As Double
    Dim amount2 As Double
    
    ' Replace with your specific column letters
    productColumn = "B"
    supplierColumn = "C"
    amount1Column = "G"
    amount2Column = "H"
    
    ' Replace with your target workbook path
    Set targetWorkbook = ThisWorkbook
    
    ' Set target worksheet name
    Set targetWorksheet = targetWorkbook.ActiveSheet ' 假设目标文件中的主工作表为活动工作表
    'Set currentSheetName = ActiveSheet.Name
    'Set targetWorksheet = targetWorkbook.Worksheets(currentSheetName)
    
    ' Input the folder path containing the source workbooks
    
    sourceFolder = InputBox("请输入目标文件路径：", "目标文件路径输入")
    sourceFolder = sourceFolder & "\"
    'sourceFolder = "C:\Users\18703\Desktop\自动化\数据\爱家影视包\"
    
    If sourceFolder = "" Then
        MsgBox "未输入目标文件路径。操作已取消。", vbExclamation
        Exit Sub
    End If
    
    '禁止刷新屏幕
    Application.ScreenUpdating = False
    
    
    Dim firstRow As String
    Dim lastRow As String
    firstRow = 2 '定义数值区域开始的行数
    lastRow = targetWorksheet.Cells(targetWorksheet.Rows.Count, "A").End(xlUp).Row '查找数值区域最后一行

    '开始循环找对应目标工作表对应工作薄中sheet中所需要的单元格数据
    For Each cell In targetWorksheet.Range(productColumn & firstRow & ":" & productColumn & lastRow)
        '产品列值和供应商值
        product = cell.MergeArea.Cells(1, 1).Value ' Get the value of the first cell in the merged range
        supplier = cell.Offset(0, 1).Value
        
        '数据源excel表的所有路径
        sourceFileName = Dir(sourceFolder & "*" & product & "*.xls*")
        
        '若数据源不为空或数据源不是目标工作表就打开对应的工作薄中的sheet
        If sourceFileName <> "" And sourceFileName <> targetWorkbook.Name Then
            Set sourceWorkbook = Workbooks.Open(sourceFolder & sourceFileName)
            Set sourceWorksheet = sourceWorkbook.Worksheets(supplier)
            
            ' 确认所需要的数据
            amount1 = sourceWorksheet.Range("P25").Value
            amount2 = sourceWorksheet.Range("Q25").Value
            
            sourceWorkbook.Close False ' 数据源选择不保存关闭
            
            ' Update the target worksheet with the values from the source workbook
            cell.Offset(0, 5).Value = amount1 ' Amount 1 column
            cell.Offset(0, 6).Value = amount2 ' Amount 2 column
        Else
            cell.Offset(0, 5).Value = "Not Found" ' Amount 1 column
            cell.Offset(0, 6).Value = "Not Found" ' Amount 2 column
        End If
    Next cell
    
    '禁止刷新屏幕
    Application.ScreenUpdating = True
    
    MsgBox "数据获取完成，请确认！"
    
    ' 目标工作表保存但不关闭，确认无误后可手动关闭
    targetWorkbook.Save  ' Save changes
    
    
End Sub