合并多个工作簿

qq270850428

合并条件：待合并表表头相同，建立合并表模板

Sub 批量合并工作簿v1()                                           '//程序标准化，调用函数，用于指定文件夹下批量文件处理，文件格式相同，合并表模板各表表头行列相同
    '//by Lyndon
    Dim myP, p, myFile, fn, MyReport As String      '//声明变量，myP宏文件路径，p合并文件夹路径，myFile合并文件变量， _
                                                    fn合并文件名称,MyReport模板文件名称
    Dim fd As Object                                '//声明变量，对象变量
    Dim t As String                                 '//声明变量，t时间变量
    Dim iCount As Integer                           '//声明变量，处理文件计数

    Dim r, r1, c, iRow As Integer                   '//声明变量，r固定行号，c固定列号，iRow行数变量
    Dim wb      As Workbook                         '//声明对象变量，模板文件赋值
    Dim sht     As Worksheet                        '//声明对象变量，模板文件sheet变量

    On Error Resume Next                                        '// 发生错误，自动执行下一句，就是忽略错误
    Application.ScreenUpdating = False                          '//关闭屏幕刷新
    Application.DisplayAlerts = False                           '//关闭系统提示
    t = Timer                                                   '//开始时间
    iCount = 0

   '--------数据初始化参数设置---------------------------'//固定行与列的情况
    r = 3                                               '//表头行数赋值
    c = 13                                              '//表头列数赋值
    r1 = 36                                             '//表头行数，要求所有表行数都一致
    myP = ActiveWorkbook.Path                           '//获取当前工作簿路径
    MyReport = "合并总表模板.xlsx"          '//定义模板文件
   '---------------------------------------------------

    Set wb = Workbooks.Open(Filename:=myP & "\" & MyReport, Password:="")   '//打开文件，并输入对应密码，##注：对象变量在过程中不显示值

    For Each sht In wb.Sheets                                               '//遍历模板文件sheet表
        sht.Rows(r + 1 & ":1048576").Clear                                  '//清除表，除表头外
    Next

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)  '//打开选择文件夹的对话框
    With fd                                                     '//如果选择了文件夹则提取文件的路径信息，否则退出
        If .Show = -1 Then                                      '//如果选择了文件夹，Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）
            p = .SelectedItems(1) & "\"                         '//获取路径
        Else
            Exit Sub
        End If
    End With


    Application.Run "HeBing", wb, p, r, r1, c                   '//调用自定义函数，合并表

    wb.SaveAs Filename:=p & "合并表.xlsx", Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
           CreateBackup:=False                                  '//模板另存为文件
    ActiveWorkbook.Close                                        '//关闭文件


    Application.ScreenUpdating = True                           '//恢复屏幕刷新
    Application.DisplayAlerts = True                            '//恢复系统提示
    MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒"   '//提示所用时间

End Sub

Private Function HeBing(wb As Workbook, p As String, r, r1, c As Integer)       '//合并多个工作簿中的多个表
    '//by Lyndon,2018-01-19

    Dim iCount, iRow As Integer                                     '//定义变量
    Dim rng As Range                                                '//定义变量
    Dim fil As Workbook                                             '//待合并文件赋值
    Dim sht As Worksheet                                            '//模板sheet表变量
    Dim myFile, fn As String                                        '//myFile待合并文件名称全称，带后缀,fn不带后缀

    On Error Resume Next                                            '//发生错误，自动执行下一句，就是忽略错误
    myFile = Dir(p & "*.xlsx")                                      '//遍历文件夹，获得文件的全称，带后缀名
    fn = Split(myFile, ".")(0)                                      '//通过Splite函数取得文件名称，不带后缀名

    Do While fn <> ""                                                   '//fn不为空
        If fn <> "某某" And fn <> ThisWorkbook.Name Then                '//不合并“某某”表。特殊表排除
            Set fil = Workbooks.Open(p & "\" & myFile, Password:=fn)    '//打开待合并文件并赋值
            fil.Sheets(1).Select                                        '//此法可取消表组合，表组合会影响到合并，重复合并
            For Each sht In wb.Sheets                                   '//遍历模板表
                If fil.Sheets(sht.Name) Is Nothing Then                 '//判断指定的工作表是否存在
                'If Not fil.Sheets(sht.Name) Is Nothing Then            '//正向判断

                Else                                                    '

                    Set rng = sht.Range("C1048576").End(xlUp).Offset(1, -1)         '//C列值不为空，B列有空值
                    iRow = sht.Range("C1048576").End(xlUp).Offset(1, -1).Row        '//取合并表已用行数
                    fil.Sheets(sht.Name).Range("A" & r + 1).Resize(r1, c).Copy rng  '//复制新打开工作簿的第一个工作表的已用区域到当前工作表
                    sht.Range("A" & iRow & ":A" & iRow + r1 - 1).Value = fn         '//合并表中第一列省区赋值

                End If
            Next sht

        End If
        fil.Close False                                         '//关闭打开的待合并文件
        iCount = iCount + 1                                     '//计数
        myFile = Dir                                            '//重新赋值
        If myFile <> "" Then                                    '//最后一个文件myFile为空时，fn不能正常取值，这里做修正
            fn = Split(myFile, ".")(0)                          '//再次取文件名称，不带后缀
        Else
            fn = ""                                             '//当myFile为空时，fn也为空
        End If
    Loop

End Function

gbb317

大神，这个可以用于xlsm的工作簿合并吗？
我试了下不行，不知道是不是要改动什么？