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执行效果视频

数据自动汇总

vbnet 复制代码
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
相关推荐
The god of big data6 小时前
深入探索 DeepSeek 在数据分析与可视化中的应用
ai·数据挖掘·数据分析
云只上6 小时前
前端插件使用xlsx-populate,花样配置excel内容,根据坐添加标替换excel内容,修改颜色,合并单元格...。
excel
小哥山水之间8 小时前
在 Python 中操作 Excel 文件
开发语言·python·excel
blog_wanghao9 小时前
C#: 创建Excel文件并在Excel中写入数据库中的数据
数据库·c#·excel
赵钰老师15 小时前
【深度学习】遥感影像目标检测:从CNN(Faster-RCNN)到Transformer(DETR)
pytorch·深度学习·目标检测·机器学习·数据分析·cnn·transformer
游客52016 小时前
自动化办公|通过xlwings进行excel格式设置
python·自动化·excel
喝西瓜汁的兔叽Yan16 小时前
第三方库XLSX: 前端上传excel文件,并对excel文件内容做校验。
前端·excel·xlsx
♢.*18 小时前
析言GBI:用自然语言交互重构企业数据分析范式
人工智能·数据分析·大模型·交互·bi·阿里
初尘屿风1 天前
基于Python的Diango旅游数据分析推荐系统设计与实现+毕业论文(15000字)
数据库·spring boot·python·数据挖掘·数据分析·旅游
莫叫石榴姐1 天前
DeepSeek驱动下的数据仓库范式转移:技术解耦、认知重构与治理演进
大数据·数据仓库·人工智能·重构·数据分析·deep learning