5、提取多工作簿指定工作表（名字查找），输出一张表

最新推荐文章于 2024-07-12 17:43:45 发布

年景@

最新推荐文章于 2024-07-12 17:43:45 发布

阅读量308

点赞数 7

分类专栏： VBA 文章标签：汇编

本文链接：https://blog.csdn.net/weixin_73737526/article/details/139033914

版权

VBA 专栏收录该内容

6 篇文章 0 订阅

订阅专栏

'前提：合并文件夹内存在多工作簿文件，每个工作簿中存在多个sheet表。现在要汇总指定sheet表，最后输出在一张sheet表上。

假设有：“天气周报表”，，“天气周报表1”，“天气周报”，“天气周”，“地区”等多张表，

'要求：

输入“天气”或“周报表”就可以进行查找汇总所有的天气周报表到一张表上

步骤

1、新建一个Excel文件，插入一个vba模块，复制粘贴代码到新增的模块中，运行代码

2、选择需要汇总的文件——代码运行会弹出文件选择框，选择存放文件的文件夹

3、输入需要汇总的表名——输入表名的关键词语即可（如“天气”），输入表全称也可以（如“天气周报”）

Sub 汇总指定sheet表() 
    Dim t, tqsht As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set fd = Application.FileDialog(msoFileDialogFolderPicker) '请选择合并文件所在的文件夹
    If fd.Show = -1 Then '点击确定时，输出-1
        t = fd.SelectedItems(1) '记录文件夹名称
    Else
        MsgBox "未选择文件夹，流程退出"
        Exit Sub
    End If
    tqsht = InputBox("请输入提取表名的关键字")
    
    Dim arr()
    Dim wj, ad As String
    Dim r, c, u As Integer
    Dim tw, wb As Workbook
    Dim sht, twsht As Worksheet
    
    Set tw = ThisWorkbook
    wj = Dir(t & "\*.xls*") '获取文件夹内工作簿名称
    ReDim arr(1 To 1)
    If wj = "" Then
        Exit Sub
    End If
    Do While wj <> ""
        u = u + 1
        ReDim Preserve arr(1 To u)
        arr(UBound(arr)) = wj
        wj = Dir
    Loop
    
    tw.Sheets(1).Name = tqsht & "汇总"
    Set twsht = tw.Sheets(1)
    twsht.Cells.Clear
    
    For i = LBound(arr) To UBound(arr)
        Set wb = Workbooks.Open(t & "\" & arr(i))
            With wb
                For Each sht In .Sheets
                    If sht.Name Like "*" & tqsht & "*" Then
                        If twsht.Cells(1, 1).CurrentRegion.Rows.Count = 1 Then
                            sht.Cells(1, 1).CurrentRegion.Copy twsht.Range("A1") '复制、粘贴格式和值
                        Else
                            ad = twsht.Range("A1").CurrentRegion.SpecialCells(xlCellTypeLastCell).Address
                            'Range("A2: " & ad)中数字 2 可以修改，此处默认第 1 行为标题行，从第 2 行开始复制、粘贴
                            sht.Range("A2: " & ad).Copy twsht.Range("A" & twsht.Cells(1, 1).CurrentRegion.Rows.Count + 1)
                        End If
                    End If
                Next sht
            End With
        wb.Close
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub