ExcelVBA汇总多工作簿中指定工作表到新工作簿

ExcelVBA汇总多工作簿中指定工作表到新工作簿

=====start====

1.VBA汇总文件夹中的多文件的工作表中不同单元格区域到总表

2.Power Query-汇总文件夹中多工作簿多工作表到一个文件

=====end====

【问题】

老板指示,请2022年12个月的xx补贴表汇总表汇总在一起上交

【思路】

【解决】一个一个打开复制，格式会散，要数值化，重新调整格式。数量不多还可以，有没有快一点的方法呢？如果是100个文件，汇总他们其中的“汇总表”那怎么办呢【方法】先取得一个文件的路径再一个一个文件打开，复制工作表，格式就不变，工作表要重新命名，用文件名来命名，但是汇总表通常里面有公式的，还要数值化

【代码】

代码语言：javascript复制

Sub yhd_ExcelVBA汇总多工作簿中指定工作表到新工作簿()
    Dim strPath As String, myshtName As String, fileName As String, Fso As Object
    Dim wb As Workbook, wbopen As Workbook, wsNew As Worksheet, sht As Worksheet
    Set Fso = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    ChDrive strPath
    ChDir strPath
    fileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "打开文件", , True)
    If TypeName(fileToOpen) = "Boolean" Then MsgBox "你选择了“取消”,将要退出程序": Exit Sub
    myshtName = Application.InputBox(prompt:="输入工作表名称", Title:="请输入", Default:="汇总", Type:=2)
    '定义变量
    disAppSet (False)
    '设置工作簿
    Set wb = ThisWorkbook
    '设置要复制的工作表
    For Each ff In fileToOpen
        '取文件名，用于工作表命名
        fileName = Fso.GetBaseName(ff)
        Set wbopen = Workbooks.Open(ff)
        With wbopen
            For Each sht In .Worksheets
                If InStr(sht.Name, myshtName) Then
                    sht.Copy after:=wb.Worksheets(wb.Worksheets.Count)
                    Set wsNew = wb.Worksheets(wb.Worksheets.Count)
                    wsNew.UsedRange.Value = wsNew.UsedRange.Value
                    wsNew.Name = fileName
                End If
            Next
            .Close False
        End With
    Next
    disAppSet (True)
End Sub
    '用法：disAppSet(true)开disAppSet(true)关
Sub disAppSet(flag As Boolean)
    With Application
        .ScreenUpdating = flag
        .DisplayAlerts = flag
        .AskToUpdateLinks = flag
        If flag Then
            .Calculation = xlCalculationAutomatic
        Else
            .Calculation = xlCalculationManual
        End If
    End With
End Sub

set string 变量 程序 工作

0 人点赞