Excel应用实践15：合并多个工作表

学习Excel技术，关注微信公众号：
excelperfect

有时候，我们需要将工作簿中的所有工作表的数据合并到一个工作表中。如果工作表数量很少，可以直接手工使用复制粘贴操作，然而，如果工作表很多并且工作表中的数据量很大，手工复制既繁琐又容易出错漏。

还好有VBA，对于这种情况，编写少量的代码，即可迅速且准确无误地完成合并工作。

下面的代码假设每个工作表中的标题行相同。代码将新建一个工作表，将工作簿所有工作表中的数据合并到这个新工作表中。
Sub CombineSheets()
'声明变量
Dim lngSheets As Long
Dim arrSheetNames As Variant
Dim rngCopy As Range
Dim rngPaste As Range
Dim rngTarget As Range
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim i As Long

'以当前工作表中的数量定义数组大小
ReDim arrSheetNames(1 ToThisWorkbook.Worksheets.Count)

'遍历工作表并将其名称存储在数组中
For i = LBound(arrSheetNames) To(UBound(arrSheetNames))
      arrSheetNames(i) = ThisWorkbook.Worksheets(i).Name
Next i

'添加一个新工作表并将其放置在所有工作表之后
With ThisWorkbook
      Set wksNew =.Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
End With

'设置粘贴数据的位置
Set rngTarget =wksNew.Range("A1")

'遍历工作表并将工作表中的数据粘贴到新工作表中
For lngSheets = LBound(arrSheetNames) ToUBound(arrSheetNames)
      On Error Resume Next
      Set wks =ThisWorkbook.Worksheets(CStr(arrSheetNames(lngSheets)))
      If wks Is Nothing Then GoTo NextSheet

      If lngSheets = LBound(arrSheetNames)Then
         Set rngCopy = wks.UsedRange
         Set rngPaste = rngTarget
      Else
         '更新粘贴数据的位置
         Set rngPaste =rngPaste.Offset(rngCopy.Rows.Count)
         With wks
            '复制除标题行之外的数据
            Set rngCopy =Intersect(.UsedRange, .UsedRange.Offset(1))
         End With
      End If

      '复制
      rngCopy.Copy
      '粘贴值与格式
      rngPaste.PasteSpecial xlPasteValues
      rngPaste.PasteSpecial xlPasteFormats

      '去除复制单元格周边的框线
      Application.CutCopyMode = False
NextSheet:
Next lngSheets

'清理变量
Set rngCopy = Nothing
Set rngPaste = Nothing
Set rngTarget = Nothing
Set wksNew = Nothing
Set wks = Nothing
End Sub

代码的图片版如下：