EXCEL-VB编程实现自动抓取多工作簿多工作表中的单元格数据

news2024/10/6 6:40:15

一、VB编程基础

1、 EXCEL文件启动宏设置

文件-选项-信任中心-信任中心设置-宏设置-启用所有宏

汇总文件保存必须以宏启动工作簿格式类型进行保存

2、 VB编程界面与入门

参考收藏
https://blog.csdn.net/O_MMMM_O/article/details/107260402?spm=1001.2014.3001.5506

二、自动抓取多工作簿多工作表中的单元格数据

1、描述

在同一路径下，有5个EXCEL工作簿，每个工作簿里面有7张工作表sheet，每张sheet里面的固定单元格有同一类型数据；1个EXCEL汇总工作簿，里面有1张工作表sheet，用来汇总抓取的数据内容。
在这里插入图片描述

2、VB程序

Sub output()
 Application.ScreenUpdating = False
 Dim Mydir As String
 Dim i As Integer
 i = 2
'获取当前工作簿所在路径'
 Mydir = ThisWorkbook.Path & "\"
  'Left(App.Path, 1)是用来返回路径中第一个字母，即盘符 如：C，D，E,chdrive则是改变当前盘'
 ChDrive Left(Mydir, 1)
 
 ChDir Mydir
 '文件名
 Match = Dir$("*.xlsx")
 Do
 If Not LCase(Match) = LCase(ThisWorkbook.Name) Then
 Workbooks.Open Match, True
 '各工作簿的文件名放到汇总表A列
 ThisWorkbook.ActiveSheet.Range("A" & i) = Match
 
 '各工作簿中SHEET1的B2单元格内容放到汇总表B列
 ThisWorkbook.ActiveSheet.Range("B" & i) = ActiveWorkbook.Sheets("sheet1").Range("A4")

 '各工作簿中SHEET2的B2单元格内容放到汇总表B列'
    ThisWorkbook.ActiveSheet.Range("D" & i) = ActiveWorkbook.Sheets("Sheet2").Range("B2")
    
    ThisWorkbook.ActiveSheet.Range("E" & i) = ActiveWorkbook.Sheets("Sheet2").Range("C2")
 ActiveWorkbook.Close 0
 i = i + 1
 End If
 Match = Dir$
 Loop Until Len(Match) = 0
 Application.ScreenUpdating = True
End Sub

如果需要采集SHEET1其他单元格数据，可以继续添加代码：

ThisWorkbook.ActiveSheet.Range("F" & i) = ActiveWorkbook.Sheets("Sheet1").Range("D3")

如果需要采集SHEET2其他单元格数据，可以继续添加代码：

ThisWorkbook.ActiveSheet.Range("F" & i) = ActiveWorkbook.Sheets("Sheet2").Range("D3")

如果工作簿的工作表、单元格和目标单元格有规律，可以用循环语句解决。

3、效果

在这里插入图片描述

附录

Sub find()

    Application.ScreenUpdating = False
    Dim Mydir As String
    Dim i As Integer
    i = 2
    
    '获取当前VBA所在Excel的路径'
    
    Mydir = ThisWorkbook.Path & "\"
    
    'Left(App.Path, 1)是用来返回路径中第一个字母，即盘符 如：C，D，E,chdrive则是改变当前盘'
    
    ChDrive Left(Mydir, 1)
    
    
    
    ChDir Mydir
    Match = Dir$("*.xls")
    Do
    If Not LCase(Match) = LCase(ThisWorkbook.Name) Then
    Workbooks.Open Match, 0, 1
    '文件名放到汇总表A列'
    ThisWorkbook.ActiveSheet.Range("A" & i) = Match
    
    '各工作簿中SHEET1的B2单元格内容放到汇总表B列'
    ThisWorkbook.ActiveSheet.Range("B" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B2")
    
    ThisWorkbook.ActiveSheet.Range("C" & i) = ActiveWorkbook.Sheets("Sheet1").Range("C2")
     
     '各工作簿中SHEET2的B2单元格内容放到汇总表B列'
    ThisWorkbook.ActiveSheet.Range("D" & i) = ActiveWorkbook.Sheets("Sheet2").Range("B2")
    
    ThisWorkbook.ActiveSheet.Range("E" & i) = ActiveWorkbook.Sheets("Sheet2").Range("C2")
    ActiveWorkbook.Close 0
    i = i + 1
    End If
    Match = Dir$
    Loop Until Len(Match) = 0
    Application.ScreenUpdating = True
End Sub