首页 › WPS/Office论坛 › Excel·VBA合并工作簿的实现示例

风向思维 發表於 2023-6-5 08:41:59

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

<div id="navCategory"><h5 class="catalogue">目录</h5><ul class="first_class_ul"><li><a href="#_label0">1，合并文件夹下所有工作簿</a></li><ul class="second_class_ul"><li><a href="#_lab2_0_0">1.1，合并且建立超链接目录</a></li></ul><li><a href="#_label1">2，合并工作簿中所有工作表</a></li><ul class="second_class_ul"><li><a href="#_lab2_1_1">2.1，纵向合并</a></li><li><a href="#_lab2_1_2">2.2，横向合并</a></li></ul><li><a href="#_label2">3，合并文件夹下所有工作簿中所有工作表</a></li><ul class="second_class_ul"><li><a href="#_lab2_2_3">3.1，合并且显示原工作簿名称、原工作表名称</a></li></ul><li><a href="#_label3">4，合并文件夹下所有工作簿中同名工作表</a></li><ul class="second_class_ul"><li><a href="#_lab2_3_4">4.1，合并且显示原工作簿名称</a></li></ul></ul></div><p class="maodian"><a name="_label0"></a></p><h2>1，合并文件夹下所有工作簿</h2>
<p>适用将所有工作簿中所有工作表复制到1个新建工作簿中，不修改数据，原本一共有多少个工作表，合并后就有多少个工作表<br />如果存在同名工作表，复制后工作表名称会自动添加序号，如Sheet1 (2)</p>
<div class="jb51code"><pre class="brush:vb;">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 &amp; "*.xlsx")
    Application.ScreenUpdating = False'关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    Set write_wb = Workbooks.Add    '新建工作簿，合并文件
    Do While file_name &lt;&gt; ""
      Set wb = Workbooks.Open(file_path &amp; 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 &amp; "合并表.xlsx"
    write_wb.SaveAs filename:=save_file
    write_wb.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
</pre></div>
<p class="maodian"><a name="_lab2_0_0"></a></p><h3>1.1，合并且建立超链接目录</h3>
<div class="jb51code"><pre class="brush:vb;">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&amp;
    file_path = "E:\测试\拆分表\"'待合并工作簿所在的文件夹
    file_name = Dir(file_path &amp; "*.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 &lt;&gt; ""
      Set wb = Workbooks.Open(file_path &amp; file_name)
      For Each sht In wb.Worksheets
            sht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)
            full_name = fso.GetBaseName(file_name) &amp; "-" &amp; 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:="'" &amp; newname &amp; "'!a1", TextToDisplay:=newname
      Next
      wb.Close (False)
      file_name = Dir'下一个文件名
    Loop
    '保存文件
    list_ws.Columns(1).AutoFit'列宽自适应
    save_file = file_path &amp; "合并表.xlsx"
    write_wb.SaveAs filename:=save_file
    write_wb.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
</pre></div>
<p>举例</p>
<p>合并《<a href="https://www.jb51.net/article/273621.htm" target="_blank">Excel&middot;VBA按列拆分工作表</a>》，sub2拆分后的工作表</p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014355.jpg" /></p>
<p>并且每个工作簿中的工作表复制1个副本（1个地名表1个Sheet1表），这样就有5个工作簿各含2个工作表<br />工作簿合并且建立超链接目录结果</p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014356.jpg" /></p>
<p class="maodian"><a name="_label1"></a></p><h2>2，合并工作簿中所有工作表</h2>
<p>对工作簿中相同格式的工作表进行合并，汇总所有工作表，保存在工作簿最前</p>
<p class="maodian"><a name="_lab2_1_1"></a></p><h3>2.1，纵向合并</h3>
<div class="jb51code"><pre class="brush:vb;">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 &gt; 0 Then copy_title = True Else copy_title = False'是否复制表头
    If title_row &lt; 0 Then Debug.Print "title_row参数错误，必须为&gt;=0的整数": Exit Sub
    Application.ScreenUpdating = False'关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    '遍历，复制表体
    For i = 1 To Worksheets.count:
      If Worksheets(i).Name &lt;&gt; ws.Name Then
            If copy_title = True Then'复制表头，仅执行1次
                Worksheets(i).Rows(1 &amp; ":" &amp; 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 &amp; ":" &amp; sheet_row - end_row).Copy ws.Range("A" &amp; write_row)
      End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
</pre></div>
<p>举例</p>
<p>合并《<a href="https://www.jb51.net/article/273621.htm" target="_blank">Excel&middot;VBA按列拆分工作表</a>》，sub1拆分后的工作表</p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014357.jpg" /></p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014458.jpg" /></p>
<p>合并参数：title_row = 1，end_row = 0</p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014459.jpg" /></p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014460.jpg" /></p>
<p class="maodian"><a name="_lab2_1_2"></a></p><h3>2.2，横向合并</h3>
<div class="jb51code"><pre class="brush:vb;">Sub 合并工作簿中所有工作表_横向()
    '当前工作簿wb所有工作表ws合并保存至新建工作表（插入最前），但之前ws不修改（工作表格式相同）
    Dim ws As Worksheet, sht As Worksheet, write_col&amp;
    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 &lt;&gt; 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
</pre></div>
<p>举例</p>
<p>合并前</p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014461.jpg" /></p>
<p>合并后</p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014462.jpg" /></p>
<p class="maodian"><a name="_label2"></a></p><h2>3，合并文件夹下所有工作簿中所有工作表</h2>
<p>对相同格式的工作簿进行合并，汇总所有工作表，保存为单独工作簿</p>
<div class="jb51code"><pre class="brush:vb;">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 &amp; "*.xlsx")
    If title_row &gt; 0 Then copy_title = True Else copy_title = False'是否复制表头
    If title_row &lt; 0 Then Debug.Print "title_row参数错误，必须为&gt;=0的整数": Exit Sub
    Application.ScreenUpdating = False'关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    Workbooks.Add    '新建工作表
    Set ws = ActiveSheet
    ws.Name = "合并表"
    Do While file_name &lt;&gt; ""
      Set wb = Workbooks.Open(file_path &amp; file_name)
      For i = 1 To Worksheets.count:
            If copy_title = True Then'复制表头，仅执行1次
                wb.Worksheets(i).Rows(1 &amp; ":" &amp; 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 &amp; ":" &amp; sheet_row - end_row).Copy ws.Range("A" &amp; write_row)
      Next
      wb.Close (False)
      file_name = Dir'下一个文件名
    Loop
    '保存文件
    save_file = file_path &amp; "合并表.xlsx"
    ws.Parent.SaveAs filename:=save_file
    ws.Parent.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
</pre></div>
<p>举例</p>
<p>合并《<a href="https://www.jb51.net/article/273621.htm" target="_blank">Excel&middot;VBA按列拆分工作表</a>》，sub2拆分后的工作表</p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014355.jpg" /></p>
<p>合并参数：title_row = 0，end_row = 0</p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014563.jpg" /></p>
<p style="text-align:center"><img alt="在这里插入图片描述" src="https://img.jbzj.com/file_images/article/202301/2023012911014564.jpg" /></p>
<p class="maodian"><a name="_lab2_2_3"></a></p><h3>3.1，合并且显示原工作簿名称、原工作表名称</h3>
<p>应评论建议，增加在A列显示原工作簿名称，B列显示原工作表名称</p>
<div class="jb51code"><pre class="brush:vb;">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 &amp; "*.xlsx")
    If title_row &gt; 0 Then copy_title = True Else copy_title = False'是否复制表头
    If title_row &lt; 0 Then Debug.Print "title_row参数错误，必须为&gt;=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 &lt;&gt; ""
      Set wb = Workbooks.Open(file_path &amp; 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 &amp; "合并表.xlsx"
    ws.Parent.SaveAs filename:=save_file
    ws.Parent.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
</pre></div>
<p class="maodian"><a name="_label3"></a></p><h2>4，合并文件夹下所有工作簿中同名工作表</h2>
<p>对工作簿按工作表名称进行合并，汇总所有同名工作表，保存为单独工作簿</p>
<div class="jb51code"><pre class="brush:vb;">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 &amp; "*.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 &lt;&gt; ""
      Set wb = Workbooks.Open(file_path &amp; 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 &amp; ":" &amp; sheet_row - end_row).Copy write_ws.Range("A" &amp; write_row)
            End If
            'Exit Do
      Next
      wb.Close (False)
      file_name = Dir'下一个文件名
    Loop
    '保存文件
    save_file = file_path &amp; "合并表.xlsx"
    write_wb.SaveAs filename:=save_file
    write_wb.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
</pre></div>
<p class="maodian"><a name="_lab2_3_4"></a></p><h3>4.1，合并且显示原工作簿名称</h3>
<p>应评论建议，增加在A列显示原工作簿名称；因按同名工作表合并，故没有显示原工作表名称的必要</p>
<div class="jb51code"><pre class="brush:vb;">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 &amp; "*.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) = "": = "原工作簿名称"
    Next
    Do While file_name &lt;&gt; ""
      Set wb = Workbooks.Open(file_path &amp; 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: = "原工作簿名称"'插入列
                Range("a2:a" &amp; 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" &amp; 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 &amp; "合并表.xlsx"
    write_wb.SaveAs filename:=save_file
    write_wb.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
</pre></div>

查看完整版本: Excel·VBA合并工作簿的实现示例