|
以前做了几个合并工作表的示例，大多可根据要求实现，当工作过程中再次应用的时候，发现以前的内容有点不适合，由于工作表结构变化，其使用过程中出了一些并不符合的现象。 实现流程 本节将利用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
整个过程实现后可以得到一个新工作薄，工作薄名称以日期和日期合并得到字符，也可根据自己实际情况进行修改。
|
