同一个文件夹内多个表怎么可以快速合并，求指点

107976422

很多个表，就是表头固定，按照表头固定的格式汇总，这样可以避免汇总出错。有高手会的吗？

不知道为什么

论坛搜搜，太多了

ni57

分享


下面是很可爱的看见星光老师的作品：：：：：：：：：


嗨，大家好，我是星光。


之前咱们分享过一段VBA小代码，作用是将多个工作表的数据汇总成总表，但那段代码并没有保留原工作表的格式。在实际工作中，有些朋友是需要保留源表格式的。

以下代码在将各工作表数据汇总的同时，也保留了源表格式。

Sub CollectDataFromShtFormat()
    Dim sht As Worksheet, rng As Range, k As Long, nTitleCount As Long
    On Error Resume Next
    nTitleCount = Val(InputBox("请输入标题的行数", "提醒", 1))
    If nTitleCount < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub
    Application.ScreenUpdating = False
    Cells.ClearContents '清空当前表数据
    For Each sht In Worksheets '遍历工作表
        If sht.Name <> ActiveSheet.Name Then
        '如果工作表名称不等于当前表名则进行汇总动作……
            Set rng = sht.UsedRange
            k = k + 1 '累计K值
            If k = 1 Then '如果是首个表格，则K为1，则把标题行一起复制到汇总表
                sht.Cells.Copy: Range("a1").PasteSpecial Paste:=xlPasteFormats '只粘贴格式
                rng.Copy: Range("a1").PasteSpecial Paste:=xlPasteValues '只粘贴数值
            Else '否则，扣除标题行后再复制黏贴到总表，只黏贴数值
                rng.Offset(nTitleCount).Copy
                With Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1)
                    .PasteSpecial Paste:=xlPasteFormats '粘贴格式
                    .PasteSpecial Paste:=xlPasteValues '粘贴数值
                End With
            End If
        End If
    Next
    Range("a1").Activate
    Application.ScreenUpdating = True '恢复屏幕刷新
    MsgBox "汇总OK，一共汇总了：" & k & "张工作表"
End Sub

动画演示效果如下：


代码三五行，工作不用忙断肠，你也试一下吧~

ni57

看成多工作表合并了，你的意思应该是：合并 同一文件夹内多个工作簿的工作表
仍然是借花，分享很厉害的看见星光的作品：

Sub 汇总工作簿的工作表()
'分享
'看见星光作品
'
    Dim strPath$, strBookName$, strKey1, strKey2, strShtName$, k&
    Dim sht As Worksheet, shtActive As Worksheet
    On Error Resume Next
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then strPath = .SelectedItems(1) Else: Exit Sub
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strKey1 = InputBox("请输入工作簿名称所包含的关键词。" & vbCr & "关键词可以为空，如为空，则默认选择全部工作簿")
    If StrPtr(strKey1) = 0 Then Exit Sub
    '如果用户点击了取消或关闭按钮，则退出程序
    strKey2 = InputBox("请输入工作表名称所包含的关键词。" & vbCr & "关键词可以为空，如为空，则默认选择符合条件工作簿的全部工作表")
    If StrPtr(strKey2) = 0 Then Exit Sub
    Set shtActive = ActiveSheet
    '当前工作表，赋值变量,代码运行完毕后，回到此表
    strBookName = Dir(strPath & "*.xls*")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Do While strBookName <> ""
        If strBookName = ThisWorkbook.Name Then
            MsgBox "注意：指定文件夹中存在和当前表格重名的工作簿！！" & vbCr & "该工作簿无法打开，工作表无法复制。"
            '当出现重名工作簿时，提醒用户。
        Else
            If InStr(1, strBookName, strKey1, vbTextCompare) Then
            '工作簿名称是否包含关键词，关键词不区分大小写
                With GetObject(strPath & strBookName)
                    For Each sht In .Worksheets
                        If InStr(1, sht.Name, strKey2, vbTextCompare) Then
                        '工作表名称是否包含关键词，关键词不区分大小写
                            If Application.CountIf(sht.UsedRange, "<>") Then
                            '如果表格存在数据区域
                                strShtName = Split(strBookName, ".xls")(0) & "-" & sht.Name
                                '复制来的工作表以"工作簿-工作表"形式起名。
                                ThisWorkbook.Sheets(strShtName).Delete
                                '如果已存在相关表名，则删除
                                sht.Copy after:=ThisWorkbook.Worksheets(Sheets.Count)
                                k = k + 1
                                '复制Sht到代码所在工作簿所有工作表的后面，并累计个数
                                ActiveSheet.Name = strShtName
                                '工作表命名。
                            End If
                        End If
                    Next
                    .Close False
                    '关闭工作簿
                End With
            End If
        End If
        strBookName = Dir
        '下一个符合条件的文件
    Loop
    shtActive.Select
    '回到初始工作表
    MsgBox "工作表收集完毕，共收集：" & k & "个"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub