VBA编程，合并多个工作表到一个表，源代码

以前做了几个合并工作表的示例，大多可根据要求实现，当工作过程中再次应用的时候，发现以前的内容有点不适合，由于工作表结构变化，其使用过程中出了一些并不符合的现象。

实现流程

本节将利用vba代码，实现从多个工作薄中提取所有不为空表的工作表，合并到一个新建工作表中，实现多表合一。

可以实现工作表汇总，把各分部汇总的表统一进行整合的场景下，使用更加方便。

合并之后如下图所示：

合并的前提是工作表结构要相同，当然，不相同也可以，可能再次进行计算处理的时候，要进行修整操作。

本示例进行的是一个傻瓜式合并，也就是不管三七二十一，进行数据追加合并，不会考虑工作表的结构是否一致。

当然了，空表是不会合并的，代码中进行了一筛选。

代码

代码是整个操作的一个灵魂，如果完整理解了代码中的过程方法，那么就对工作表合并有了一个基本认识。

执行入口

Private Sub JoinSheet()
Application.Caption = "江觅"
Dim NewWork As Workbook, xName As String
xName = Application.InputBox("输入工作薄名称", "合并工作表", VBA.Format(VBA.Date, "yyyymmdd") & VBA.Format(VBA.Time, "hhmm"))
If VBA.Len(xName) = 0 Then Exit Sub
If xName = False Then Exit Sub
Set NewWork = Application.Workbooks.Add()
NewWork.SaveAs ThisWorkbook.Path & "\" & xName & ".xlsx"
Dim si As Integer
With Application.FileDialog(msoFileDialogFilePicker)
    If .Show = -1 Then
    .Filters.Clear
    .Filters.Add "Excle文件", "*.xls;*.xlsx"
    .AllowMultiSelect = True
            For si = 1 To .SelectedItems.Count '遍历打开工作表
                SelectCopySheet .SelectedItems(si), NewWork
            Next si
    MsgBox xName & VBA.vbCrLf & "复制完成。", vbInformation, "成功"
    End If
End With
End Sub

循环

遍历要复制的工作表，并调用合并函数

Public Sub SelectCopySheet(xWorkName As String, NewWork As Workbook)
'选择工作表，调用复制表内容函数
On Error Resume Next
Dim s As Workbook
Application.Workbooks.Open xWorkName
Set s = ActiveWorkbook
Dim xSheet As Worksheet, R As Range
For Each xSheet In s.Worksheets
    Set R = CheckIsBlack(xSheet)
    If Not R Is Nothing Then '如果不是空表
       CopySheetToNewSheet R, NewWork '复制工作表
    End If
Next xSheet
s.Close
Set R = Nothing
Set xSheet = Nothing
Set s = Nothing
End Sub

追加复制

Public Sub CopySheetToNewSheet(R As Range, NewWork As Workbook)
'追加复制内容到新工作表
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Dim xSheet As Worksheet
    Dim wr As Integer, wc As Integer
    Set xSheet = NewWork.Worksheets(1)
    wr = xSheet.UsedRange.Rows.Count + 1
    wc = xSheet.UsedRange.Columns.Count
    If wr = 2 Then wr = 1
    xSheet.Cells(wr, 1).Select
    R.Copy
    xSheet.Cells(wr, 1).PasteSpecial xlPasteAll
    NewWork.Save
    Set xSheet = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

整个过程实现后可以得到一个新工作薄，工作薄名称以日期和日期合并得到字符，也可根据自己实际情况进行修改。

欢迎关注、收藏

---END---