Excel·VBA合并工作簿的实现示例

sub 合并文件夹下所有工作簿()
    '文件夹下所有工作簿wb所有工作表ws合并为一个新工作簿（但不含子文件夹），不修改数据
    dim write_wb as workbook, wb as workbook, sht as worksheet, file_path$, file_name$
    file_path = "e:\测试\拆分表\"  '待合并工作簿所在的文件夹
    file_name = dir(file_path & "*.xlsx")
    application.screenupdating = false  '关闭屏幕更新，加快程序运行
    application.displayalerts = false   '不显示警告信息
    set write_wb = workbooks.add    '新建工作簿，合并文件
    do while file_name <> ""
        set wb = workbooks.open(file_path & file_name)
        for each sht in wb.worksheets
            sht.copy after:=write_wb.sheets(write_wb.sheets.count)
        next
        wb.close (false)
        file_name = dir  '下一个文件名
    loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    write_wb.saveas filename:=save_file
    write_wb.close (false)
    application.screenupdating = true
    application.displayalerts = true
end sub

sub 合并文件夹下所有工作簿并建立目录()
    '文件夹下所有工作簿wb所有工作表ws合并为一个新工作簿（但不含子文件夹），不修改数据，并建立目录超链接
    dim write_wb as workbook, wb as workbook, list_ws as worksheet, sht as worksheet
    dim fso as object, file_path$, file_name$, full_name$, newname$, w&
    file_path = "e:\测试\拆分表\"  '待合并工作簿所在的文件夹
    file_name = dir(file_path & "*.xlsx")
    application.screenupdating = false  '关闭屏幕更新，加快程序运行
    application.displayalerts = false   '不显示警告信息
    set write_wb = workbooks.add    '新建工作簿，合并文件
    set list_ws = write_wb.worksheets(1): list_ws.name = "目录"
    list_ws.cells(1, 1) = "目录(原工作簿名-工作表名)": list_ws.cells(1, 2) = "超链接": w = 1
    set fso = createobject("scripting.filesystemobject")
    do while file_name <> ""
        set wb = workbooks.open(file_path & file_name)
        for each sht in wb.worksheets
            sht.copy after:=write_wb.sheets(write_wb.sheets.count)
            full_name = fso.getbasename(file_name) & "-" & sht.name  '原工作簿名-工作表名
            'write_wb.sheets(write_wb.sheets.count).name = full_name  '可对复制的ws重命名
            w = w + 1: list_ws.cells(w, 1) = full_name: newname = write_wb.sheets(write_wb.sheets.count).name
            list_ws.hyperlinks.add anchor:=list_ws.cells(w, 2), address:="", subaddress:="'" & newname & "'!a1", texttodisplay:=newname
        next
        wb.close (false)
        file_name = dir  '下一个文件名
    loop
    '保存文件
    list_ws.columns(1).autofit  '列宽自适应
    save_file = file_path & "合并表.xlsx"
    write_wb.saveas filename:=save_file
    write_wb.close (false)
    application.screenupdating = true
    application.displayalerts = true
end sub

sub 合并工作簿中所有工作表_纵向()
    '当前工作簿wb所有工作表ws合并保存至新建工作表（插入最前），但之前ws不修改（工作表格式相同）
    dim wb, ws, title_row, end_row, copy_title, i
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字
    title_row = 1  '表头行数，仅复制1次；如果为0，则表示没有表头或表头每次都复制
    end_row = 0    '表尾行数，不参与合并
    set wb = application.activeworkbook  '当前工作簿即为待合并工作簿
    set ws = wb.worksheets.add(before:=sheets(1))  '最前添加新sheet，即为合并工作表
    ws.name = "合并表"
    if title_row > 0 then copy_title = true else copy_title = false  '是否复制表头
    if title_row < 0 then debug.print "title_row参数错误，必须为>=0的整数": exit sub
    application.screenupdating = false  '关闭屏幕更新，加快程序运行
    application.displayalerts = false   '不显示警告信息
    '遍历，复制表体
    for i = 1 to worksheets.count:
        if worksheets(i).name <> ws.name then
            if copy_title = true then  '复制表头，仅执行1次
                worksheets(i).rows(1 & ":" & title_row).copy ws.range("a1")
                copy_title = false
            end if
            '首行为空，会导致后续数据被覆盖
            if worksheetfunction.counta(ws.rows(1)) = 0 then ws.rows(1).delete
            write_row = ws.usedrange.rows.count + 1  '合并工作表的第一个空行写入
            sheet_row = worksheets(i).usedrange.rows.count
            worksheets(i).rows(title_row + 1 & ":" & sheet_row - end_row).copy ws.range("a" & write_row)
        end if
    next
    application.screenupdating = true
    application.displayalerts = true
end sub

sub 合并工作簿中所有工作表_横向()
    '当前工作簿wb所有工作表ws合并保存至新建工作表（插入最前），但之前ws不修改（工作表格式相同）
    dim ws as worksheet, sht as worksheet, write_col&
    application.screenupdating = false  '关闭屏幕更新，加快程序运行
    application.displayalerts = false   '不显示警告信息
    with activeworkbook
        set ws = .worksheets.add(before:=sheets(1))  '最前添加新sheet，即为合并工作表
        ws.name = "合并表"
        for each sht in .worksheets
            if sht.name <> ws.name then
                '首列为空时，会导致后续数据被覆盖
                if worksheetfunction.counta(ws.columns(1)) = 0 then ws.columns(1).delete
                write_col = ws.usedrange.columns.count + 1
                sht.usedrange.copy ws.cells(1, write_col)
            end if
        next
    end with
    application.screenupdating = true
    application.displayalerts = true
end sub

sub 合并文件夹下所有工作簿中所有工作表()
    '文件夹下所有工作簿wb所有工作表ws合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
    dim wb, ws, title_row, end_row, copy_title, file_path, file_name, save_file, i
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字；file_path，合并文件夹
    title_row = 1  '表头行数，仅复制1次；如果为0，则表示没有表头或表头每次都复制
    end_row = 0    '表尾行数，不参与合并
    file_path = "e:\测试\拆分表\"  '待合并工作簿所在的文件夹
    file_name = dir(file_path & "*.xlsx") 
    if title_row > 0 then copy_title = true else copy_title = false  '是否复制表头
    if title_row < 0 then debug.print "title_row参数错误，必须为>=0的整数": exit sub
    application.screenupdating = false  '关闭屏幕更新，加快程序运行
    application.displayalerts = false   '不显示警告信息
    workbooks.add    '新建工作表
    set ws = activesheet
    ws.name = "合并表"
    do while file_name <> ""
        set wb = workbooks.open(file_path & file_name)
        for i = 1 to worksheets.count:
            if copy_title = true then  '复制表头，仅执行1次
                wb.worksheets(i).rows(1 & ":" & title_row).copy ws.range("a1")
                copy_title = false
            end if
            '首行为空，会导致后续数据被覆盖
            if worksheetfunction.counta(ws.rows(1)) = 0 then ws.rows(1).delete
            write_row = ws.usedrange.rows.count + 1  '合并工作表的第一个空行写入
            sheet_row = wb.worksheets(i).usedrange.rows.count
            wb.worksheets(i).rows(title_row + 1 & ":" & sheet_row - end_row).copy ws.range("a" & write_row)
        next
        wb.close (false)
        file_name = dir  '下一个文件名
    loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    ws.parent.saveas filename:=save_file
    ws.parent.close (false)
    application.screenupdating = true
    application.displayalerts = true
end sub

sub 合并文件夹下所有工作簿中所有工作表1()
    '文件夹下所有工作簿wb所有工作表ws合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
    dim wb, ws, title_row, end_row, copy_title, file_path, file_name, save_file, fso as object
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字；file_path，合并文件夹
    title_row = 1  '表头行数，仅复制1次；如果为0，则表示没有表头或表头每次都复制
    end_row = 0    '表尾行数，不参与合并
    file_path = "e:\测试\拆分表\"  '待合并工作簿所在的文件夹
    file_name = dir(file_path & "*.xlsx")
    if title_row > 0 then copy_title = true else copy_title = false  '是否复制表头
    if title_row < 0 then debug.print "title_row参数错误，必须为>=0的整数": exit sub
    application.screenupdating = false  '关闭屏幕更新，加快程序运行
    application.displayalerts = false   '不显示警告信息
    set fso = createobject("scripting.filesystemobject")
    workbooks.add    '新建工作表
    set ws = activesheet: ws.name = "合并表": ws.cells(1, "a").resize(1, 2) = array("原工作簿名称", "原工作表名称")
    do while file_name <> ""
        set wb = workbooks.open(file_path & file_name)
        for each sht in wb.worksheets
            if copy_title = true then  '复制表头，仅执行1次
                sheet_col = sht.usedrange.columns.count
                sht.range(cells(1, "a"), cells(title_row, sheet_col)).copy ws.cells(1, "c")
                copy_title = false
            end if
            if worksheetfunction.counta(ws.rows(1)) = 0 then ws.rows(1).delete
            write_row = ws.usedrange.rows.count + 1  '合并工作表的第一个空行写入
            sheet_row = sht.usedrange.rows.count: sheet_col = sht.usedrange.columns.count
            sht.range(cells(title_row + 1, "a"), cells(sheet_row - end_row, sheet_col)).copy ws.cells(write_row, "c")
            ws.cells(write_row, "a").resize(sheet_row - title_row - end_row, 2) = array(fso.getbasename(file_name), sht.name)
        next
        wb.close (false)
        file_name = dir  '下一个文件名
    loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    ws.parent.saveas filename:=save_file
    ws.parent.close (false)
    application.screenupdating = true
    application.displayalerts = true
end sub

sub 合并文件夹下所有工作簿中同名工作表()
    '文件夹下所有工作簿wb所有工作表ws按名称合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
    dim dict as object, sht as worksheet, file_path$, file_name$, title_row, end_row, save_file$
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字；file_path，合并文件夹
    title_row = 1  '表头行数，不参与合并
    end_row = 0    '表尾行数，不参与合并
    file_path = "e:\测试\拆分表\"  '待合并工作簿所在的文件夹
    file_name = dir(file_path & "*.xlsx")
    application.screenupdating = false
    application.displayalerts = false
    set dict = createobject("scripting.dictionary")
    set write_wb = workbooks.add    '新建工作簿，合并文件
    '新建工作簿默认工作表，防止有同名被合并表，导致整表复制后名称改变；但会缺少表头
    for each sht in write_wb.worksheets
        dict(sht.name) = ""
    next
    do while file_name <> ""
        set wb = workbooks.open(file_path & file_name)
        for each sht in wb.worksheets
            if not dict.exists(sht.name) then  '不存在的，直接复制整表
                dict(sht.name) = ""
                sht.copy after:=write_wb.sheets(write_wb.sheets.count)
            else
                set write_ws = write_wb.worksheets(sht.name)
                '首行为空，会导致后续数据被覆盖
                if worksheetfunction.counta(write_ws.rows(1)) = 0 then write_ws.rows(1).delete
                write_row = write_ws.usedrange.rows.count + 1  '合并工作表的第一个空行写入
                sheet_row = sht.usedrange.rows.count
                sht.rows(title_row + 1 & ":" & sheet_row - end_row).copy write_ws.range("a" & write_row)
            end if
            'exit do
        next
        wb.close (false)
        file_name = dir  '下一个文件名
    loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    write_wb.saveas filename:=save_file
    write_wb.close (false)
    application.screenupdating = true
    application.displayalerts = true
end sub

sub 合并文件夹下所有工作簿中同名工作表1()
    '文件夹下所有工作簿wb所有工作表ws按名称合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
    dim dict as object, sht as worksheet, fso as object
    dim file_path$, file_name$, title_row, end_row, save_file$
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字；file_path，合并文件夹
    title_row = 1  '表头行数，不参与合并
    end_row = 0    '表尾行数，不参与合并
    file_path = "e:\测试\拆分表\"  '待合并工作簿所在的文件夹
    file_name = dir(file_path & "*.xlsx")
    application.screenupdating = false  '关闭屏幕更新，加快程序运行
    application.displayalerts = false   '不显示警告信息
    set fso = createobject("scripting.filesystemobject")
    set dict = createobject("scripting.dictionary")
    set write_wb = workbooks.add    '新建工作簿，合并文件
    '新建工作簿默认工作表，防止有同名被合并表，导致整表复制后名称改变；但会缺少表头
    for each sht in write_wb.worksheets
        dict(sht.name) = "": [a1] = "原工作簿名称"
    next
    do while file_name <> ""
        set wb = workbooks.open(file_path & file_name)
        for each sht in wb.worksheets
            if not dict.exists(sht.name) then  '不存在的，直接复制整表
                dict(sht.name) = ""
                sht.copy after:=write_wb.sheets(write_wb.sheets.count)
                activesheet.columns(1).insert: [a1] = "原工作簿名称"  '插入列
                range("a2:a" & activesheet.usedrange.rows.count).value = fso.getbasename(file_name)  '需要扩展名可直接赋值file_name
            else
                set write_ws = write_wb.worksheets(sht.name)
                if worksheetfunction.counta(write_ws.rows(1)) = 0 then write_ws.rows(1).delete
                write_row = write_ws.usedrange.rows.count + 1  '合并工作表的第一个空行写入
                sheet_row = sht.usedrange.rows.count: sheet_col = sht.usedrange.columns.count
                sht.range(cells(title_row + 1, "a"), cells(sheet_row - end_row, sheet_col)).copy write_ws.range("b" & write_row)
                write_ws.cells(write_row, "a").resize(sheet_row - title_row - end_row) = fso.getbasename(file_name)
            end if
        next
        wb.close (false)
        file_name = dir  '下一个文件名
    loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    write_wb.saveas filename:=save_file
    write_wb.close (false)
    application.screenupdating = true
    application.displayalerts = true
end sub