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