excel合并多个工作表_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

代码的图片版如下：