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

来源地址：https://blog.csdn.net/rubyw/article/details/132554319