VBA实用小程序19：合并工作簿中的所有工作表

本程序假设当前工作簿中所有工作表都有相同的表结构，相同的列标题和列顺序。新建一个名为Main的工作表，将所有工作表中的数据复制到新工作表Main中。

 

在标准模块中输入下面的代码：

Sub CombineWorksheets()

    Dim wbk As Workbook

    Dim wks As Worksheet

    Dim wksMain As Worksheet

    Dim rng As Range

    Dim lngColCount As Long

   

    '设置变量wbk为当前工作簿

    Set wbk = ActiveWorkbook

   

    '如果工作表名已存在,则给出提示信息

    For Each wks In wbk.Worksheets

        If wks.Name ='Main' Then

            MsgBox '已经存在一个名为Main的工作表.' & vbCrLf & _

                '请删除或者重命名这个工作表.' & vbCrLf & _

                '我们将使用工作表Main合并其他工作表.', _

                 vbOKOnly vbExclamation, '错误'

            Exit Sub

        End If

    Next wks

   

    Application.ScreenUpdating =False

   

    '添加新工作表并放置在最后

    With wbk

        Set wksMain =.Worksheets.Add(After:=.Worksheets(.Worksheets.Count))

    End With

   

    '将新工作表命名为Main

    wksMain.Name = 'Main'

    '从第1个工作表中获取列标题和第1行的列数

    Set wks = wbk.Worksheets(1)

    lngColCount = wks.Cells(1,Columns.Count).End(xlToLeft).Column

   

    '将列标题输入到新工作表中

    With wksMain.Cells(1,1).Resize(1, lngColCount)

        .Value = wks.Cells(1,1).Resize(1, lngColCount).Value

        .Font.Bold = True

    End With

   

    '遍历工作簿中的工作表

    For Each wks In wbk.Worksheets

        '若工作表为新添加的工作表,则退出程序

        If wks.Index =wbk.Worksheets.Count Then

            Exit For

        End If

        '获取工作表中的数据区域,从第2行开始

        With wks

            Set rng =.Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp).Resize(, lngColCount))

        End With

        '将获取的数据输入到新添加的工作表

        wksMain.Cells(Rows.Count,1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value =rng.Value

    Next wks

   

    '自动调整列宽

    wksMain.Columns.AutoFit

   

    Application.ScreenUpdating =True

End Sub