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 WorkbookDim targetWorksheet As WorksheetDim currentSheetName As StringDim sourceFolder As StringDim productColumn As StringDim supplierColumn As StringDim amount1Column As StringDim amount2Column As StringDim cell As RangeDim product As StringDim supplier As StringDim sourceFileName As StringDim sourceWorkbook As WorkbookDim sourceWorksheet As WorksheetDim amount1 As DoubleDim amount2 As Double' Replace with your specific column lettersproductColumn = "B"supplierColumn = "C"amount1Column = "G"amount2Column = "H"' Replace with your target workbook pathSet targetWorkbook = ThisWorkbook' Set target worksheet nameSet targetWorksheet = targetWorkbook.ActiveSheet ' 假设目标文件中的主工作表为活动工作表'Set currentSheetName = ActiveSheet.Name'Set targetWorksheet = targetWorkbook.Worksheets(currentSheetName)' Input the folder path containing the source workbookssourceFolder = InputBox("请输入目标文件路径：", "目标文件路径输入")sourceFolder = sourceFolder & "\"'sourceFolder = "C:\Users\18703\Desktop\自动化\数据\爱家影视包\"If sourceFolder = "" ThenMsgBox "未输入目标文件路径。操作已取消。", vbExclamationExit SubEnd If'禁止刷新屏幕Application.ScreenUpdating = FalseDim firstRow As StringDim lastRow As StringfirstRow = 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 rangesupplier = cell.Offset(0, 1).Value'数据源excel表的所有路径sourceFileName = Dir(sourceFolder & "*" & product & "*.xls*")'若数据源不为空或数据源不是目标工作表就打开对应的工作薄中的sheetIf sourceFileName <> "" And sourceFileName <> targetWorkbook.Name ThenSet sourceWorkbook = Workbooks.Open(sourceFolder & sourceFileName)Set sourceWorksheet = sourceWorkbook.Worksheets(supplier)' 确认所需要的数据amount1 = sourceWorksheet.Range("P25").Valueamount2 = sourceWorksheet.Range("Q25").ValuesourceWorkbook.Close False ' 数据源选择不保存关闭' Update the target worksheet with the values from the source workbookcell.Offset(0, 5).Value = amount1 ' Amount 1 columncell.Offset(0, 6).Value = amount2 ' Amount 2 columnElsecell.Offset(0, 5).Value = "Not Found" ' Amount 1 columncell.Offset(0, 6).Value = "Not Found" ' Amount 2 columnEnd IfNext cell'禁止刷新屏幕Application.ScreenUpdating = TrueMsgBox "数据获取完成，请确认！"' 目标工作表保存但不关闭，确认无误后可手动关闭targetWorkbook.Save  ' Save changesEnd Sub