实用VBA:7.按文件列表一键汇总excel工作簿

15 篇文章 0 订阅
13 篇文章 0 订阅

        前面介绍了通过打开文件的对话框,选择目录进行多文件一键汇总的方法,也介绍了使用VBA提取文件存储路径和文件名的方法。如果大量的表格文件分别存储在分散的不同目录下,前面介绍的汇总的方法就不太好用了。虽然也可以将分布在不同目录下的文件使用批处理命令复制汇总到同一目录下,再用第一个汇总的方法进行文件表格多合一的汇总。但毕竟有些繁琐。在提取文件列表之后,即可按列表逐一打开文件进行复制汇总。

1.需求场景

有多个相同格式的数据表文件需要汇总到一起。汇总之后可以实现将单独保存在大量文件中的表文件复制到同一个文件中,即可通过切换表格的方式分别查看各个表中的内容,而不必一遍遍打开、关闭文件。

2.解决思路

用前面介绍过的办法提取需要处理的文件列表,使用循环语句遍历每个文件,逐一打开文件,复制表格内容到当前文件,关闭临时文件。

3.VBA实现

    Dim wb, wbtmp, wbNew As Workbook

    Dim ws, sh, wsNew As Worksheet

    Dim startLine, endLine, iLine, i, j, k, n As Integer

    Dim openFile, filePath, fileName As String

    Dim last_row As Integer

    

Public Sub 多文件汇总()

    '设置工作簿变量为当前工作簿

    Set wb = Workbooks(1)

    wb.Activate

    '设置工作表为保存待汇总文件路径和文件名的表格

    Set ws = Worksheets("文件列表")

    ws.Activate

    '设置汇总文件在列表中的起始行和结束行当行号,即汇总范围

    startLine = 2

    endLine = 13

    '关闭屏幕刷新

    Application.ScreenUpdating = False

    '循环打开文件进行汇总(复制)

    For iLine = startLine To endLine

        wb.Activate

        Set ws = Worksheets("文件列表")

        ws.Activate

        '从文件列表中获取当先要处理的文件的路径和文件名。

        filePath = ws.Cells(iLine, 1).Value

        fileName = ws.Cells(iLine, 2).Value

        '拼接要打开文件的完整路径

        openFile = filePath & fileName

        '设置临时工作簿对象为打开的文件

        Set wbtmp = GetObject(openFile)

        '设置工作表为打开文件的第一个工作表

        Set sh = wbtmp.Worksheets(1)

        '将打开文件的第一个工作表复制到文件列表所在文件中,复制到当前所有表之后的位置

        sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

        '关闭临时文件

        wbtmp.Close savechanges:=True

        '输出调试信息,监控汇总进度

        Debug.Print "文件" & iLine & ": " & Right(openFile, Len(openFile) - InStrRev(openFile, "\")) & " 汇总完成。"

    Next iLine

    '打开屏幕刷新

    Application.ScreenUpdating = True

    '释放工作表和工作簿变量

    Set ws = Nothing

    Set wb = Nothing

    Set sh = Nothing

    Set wbtmp = Nothing

    '输出提示信息

    MsgBox "数据汇总完成。"

End Sub

4.实现效果

  • 0
    点赞
  • 3
    收藏
    觉得还不错? 一键收藏
  • 1
    评论
好的,你想了解如何用VBA代码一键合并汇总多个Excel工作簿,省时省力。以下是具体步骤: 1. 打开一个新的Excel工作簿,按下“Alt+F11”打开VBA编辑器。 2. 在VBA编辑器,单击菜单栏上的“插入”->“模块”,打开一个新的VBA模块。 3. 在新的VBA模块,复制以下代码: ``` Sub 合并多个工作簿() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long '关闭屏幕刷新,提高运行速度 With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With '获取要合并的工作簿所在的文件夹 MyPath = InputBox("请输入要合并的工作簿所在的文件夹路径") If MyPath = "" Then Exit Sub If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" '获取要合并的工作簿文件名 FilesInPath = Dir(MyPath & "*.xlsx") If FilesInPath = "" Then MsgBox "找不到任何Excel文件", vbInformation, "没有文件" Exit Sub End If '将要合并的工作簿文件名放入一个数组 FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop '打开第一个工作簿并将其内容复制到新的工作簿 Set BaseWks = Workbooks.Open(MyPath & MyFiles(1)).Sheets(1) rnum = BaseWks.Cells.Find(What:="*", _ After:=BaseWks.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row For FNum = 2 To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then sourceRange = mybook.Sheets(1).Range("A1").CurrentRegion SourceRcount = sourceRange.Rows.Count If SourceRcount >= 2 Then Set destrange = BaseWks.Range("A" & rnum + 1) sourceRange.Copy destrange rnum = rnum + SourceRcount End If mybook.Close SaveChanges:=False End If Next FNum BaseWks.Columns.AutoFit '恢复屏幕刷新和事件处理,并计算一次 With Application .Calculation = CalcMode .ScreenUpdating = True .EnableEvents = True End With MsgBox "合并完成" End Sub ``` 4. 将代码的“输入要合并的工作簿所在的文件夹路径”改为实际的文件夹路径。 5. 按下“F5”或点击“运行”->“运行子过程”,运行代码。 6. 程序会自动合并指定文件夹的所有Excel工作簿并将它们汇总到新的工作簿的第一个工作。 注意:在运行过程,程序会关闭屏幕刷新和事件处理功能,以提高运行速度。运行完成后,程序会自动恢复这些功能。

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论 1
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值