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

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