在汇总工作表中合并多个工作表中的数据

2009年04月7日, 1:33 下午
1 颗星2 颗星3 颗星4 颗星5 颗星 (2 人投票, 平均: 5.00 out of 5)
Loading ... Loading ...

编者按：优秀的示例和代码总是能够给人以很多启发，能够从中学习到很多实用的编程技术和技巧，更能够解决实际遇到的问题，使人受益无穷。下面将与大家一起分享Excel专家们的一些优秀的实用示例和代码，这也是学习VBA编程的良好方式。
本文介绍的是Microsoft Office Excel MVP Ron de Bruin提供的VBA代码，用来将工作簿中多个工作表里的数据合并到一个汇总工作表中。
有时，当我们使用包含有多个工作表的工作簿时，往往需要合并多个工作表中的数据到汇总工作表中，然后对汇总后的数据进行分析。下面的示例所演示的代码将在当前工作簿中添加一个工作表，并依次将工作簿内每一工作表中指定单元格区域的数据复制到所添加的新工作表中。
您可以先下载示例工作簿，以方便理解本文所介绍的内容。

注：示例代码使用了ActiveWorkbook对象，处理当前工作簿中的数据。如果希望确保代码仅作用于包含该代码的工作簿，那么使用ThisWorkbook替换ActiveWorkbook。
首先，需要添加一些通用函数用于本文中的所有示例。
添加通用函数
1、在Excel中打开一个新工作簿。
2、按Alt+F11组合键打开VBE。
3、单击“插入——模块”，添加一个新模块。
4、在模块窗口，输入下面的代码。

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(what:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function
 
Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(what:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

这两个函数分别用于查找工作表中包含数据的最后一行和最后一列。
下面，我们将复制工作簿中所有工作表的数据，并将这些数据合并到一个汇总工作表中。
复制多个工作表中的所有数据
1、在模块窗口输入下列代码：

Sub CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    '如果工作表"RDBMergeSheet"存在则将其删除
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
 
    '添加一个名为"RDBMergeSheet"的工作表
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"
 
    '遍历所有工作表并将数据复制到DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
 
            '找到在工作表DestSh中带有数据的最后一行
            Last = LastRow(DestSh)
 
            '设置希望复制的单元格区域
            Set CopyRng = sh.Range("A2:G2")
 
            '测试工作表DestSh中是否有足够的行用来复制所有数据
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "在工作表Destsh中没有足够的行用来放置数据!"
                GoTo ExitTheSub
            End If
 
            '下面的语句从每个工作表中复制值和格式
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
 
            '可选代码: 下面的语句复制工作表名称到H列
            DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
 
        End If
    Next
 
ExitTheSub:
 
    Application.GoTo DestSh.Cells(1)
 
    '自动调整DestSh工作表的列宽
    DestSh.Columns.AutoFit
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

2、按Alt+Q组合键退出VBE。
3、按Alt+F8组合键来运行代码。
在代码的开始部分（下面的示例相同）禁用屏幕更新，确保代码运行时屏幕不会闪烁。如果汇总工作表RDBMergeSheet存在则删除该工作表，然后添加一个新工作表，以确保代码运行后总是最新数据。
接下来，代码遍历每个工作表的单元格区域，复制值和格式到汇总工作表。过程中也包含了将每个工作表的名称复制到汇总工作表的H列。最后，汇总工作表调整每列的大小以适合所插入的数据。

  • 要复制源工作表中的所有带有数据的单元格，使用下面的语句： 
    Set CopyRng=sh.UsedRange
  • 要复制单元格A1所在的当前区域，使用下面的语句： 
    Set CopyRng=sh.Range(“A1”).CurrentRegion

    当前区域是所在单元格周围由空行和空列所包围的区域。

  • 要复制整行，使用下面的语句： 
    Set CopyRng=sh.Rows("1")
  • 要复制若干行，使用下面的语句： 
    Set CopyRng=sh.Rows(“1:8”)

    将复制第1行到第8行。

  • 仅复制数据而不复制格式，则将下面的代码： 
    CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
End With

    使用下面的代码替换：

    With CopyRng
    DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
  • 要复制所有值、格式、公式、数据有效性以及批注，则将下面的代码： 
    CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
End With

    使用下面的代码替换：

    CopyRng.Copy DestSh.Cells(Last+1,”A”)
  • 要仅从指定的工作表中复制数据（例如，名称以“week”开头的工作表），则将下面的代码： 
    If sh.Name <> DestSh.Name Then

    使用下面的代码替换：

    If LCase(Left(sh.Name,4)="week" Then
  • 要仅从工作簿中可见工作表中复制数据，则将下面的代码： 
    If sh.Name <> DestSh.Name Then

    使用下面的代码替换：

    If sh.Name <> DestSh.Name And sh.Visible = True Then
  • 要仅从在数组里的工作表中复制数据，则将下面的代码： 
    For Each sh In ActiveWorkbook.Worksheets

    使用下面的代码替换：

    For Each sh In ActiveWorkbook.Sheets(Array("Sheet1", "Sheet3"))

    同时，删除下面的代码：

    If sh.Name <> DestSh.Name Then
End If
  • 要排除多个工作表，则将下面的代码： 
    If sh.Name <> DestSh.Name Then

    使用下面的代码替换：

    If IsError(Application.Match(sh.Name, _
  Array(DestSh.Name, "Total Sheet", "Menu Sheet"), 0)) Then

下面，我们复制工作表中除列标题以外的所有数据到汇总工作表。
从多个工作表中复制除列标题以外的所有数据
1、在模块窗口输入下列代码：

Sub CopyDataWithoutHeaders()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    '如果工作表"RDBMergeSheet"存在则将其删除
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
 
    '添加名为"RDBMergeSheet"的工作表
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"
 
    '开始复制的行号
    StartRow = 2
 
    '遍历所有工作表并将数据复制到DestSh
    For Each sh In ActiveWorkbook.Worksheets
 
        If sh.Name <> DestSh.Name Then
 
            '找到工作表DestSh和工作表sh（源工作表）中带有数据的最后一行
            Last = LastRow(DestSh)
            shLast = LastRow(sh)
 
            '如果sh不为空并且最后一行>= StartRow则复制CopyRng
            If shLast > 0 And shLast >= StartRow Then
 
                '设置想要复制的单元格区域
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
 
                '测试工作表DestSh中是否有足够的行用来复制所有数据
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "在工作表Destsh中没有足够的行用来放置数据!"
                    GoTo ExitTheSub
                End If
 
                '下列语句复制值和格式
                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
 
            End If
 
        End If
    Next
 
ExitTheSub:
 
    Application.GoTo DestSh.Cells(1)
 
    '自动调整DestSh工作表的列宽
    DestSh.Columns.AutoFit
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

2、按Alt+Q组合键退出VBE。
3、按Alt+F8组合键来运行代码。
上述代码复制每个工作表中除开始行以外的所有数据到汇总工作表中。只是复制数据，而没有复制列标题。
下面，我们在汇总工作表中最后一列后添加数据，即将源工作表中的数据粘贴到汇总工作表带有数据的最后一列之后。
注意：Excel 2003最多只有256列，而Excel 2007则有16384列。
从多个工作表中复制数据并将其添加到汇总工作表最后一列之后
1、在模块窗口输入下列代码：

Sub AppendDataAfterLastColumn()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    '如果工作表"RDBMergeSheet"存在则将其删除
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
 
    '添加一个名为"RDBMergeSheet"的工作表
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"
 
    '遍历所有工作表并将数据复制到DestSh
    For Each sh In ActiveWorkbook.Worksheets
 
        If sh.Name <> DestSh.Name Then
 
            '找到在工作表DestSh中带有数据的最后一列
            Last = LastCol(DestSh)
 
            '设置希望复制的列
            Set CopyRng = sh.Range("A:A")
 
            '测试工作表DestSh中是否有足够的行用来复制所有数据
            If Last + CopyRng.Columns.Count > DestSh.Columns.Count Then
                MsgBox "在工作表Destsh中没有足够的列用来放置数据!"
                GoTo ExitTheSub
            End If
 
            '下列语句复制值、格式和列宽
            CopyRng.Copy
            With DestSh.Cells(1, Last + 1)
                .PasteSpecial 8    ' 列宽
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
 
        End If
    Next
 
ExitTheSub:
 
    Application.GoTo DestSh.Cells(1)
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

2、按Alt+Q组合键退出VBE。
3、按Alt+F8组合键来运行代码。
上述代码确定汇总工作表中包含数据的最后一列，然后将源工作表中A列数据添加到该列之后。引用A：A复制整列，也可以指定单元格区域例如A1：A10，还可以使用A：C来复制多列，只需修改下面的代码：

Set CopyRng=sh.Range("A:A")

在VBA中使用公式合并工作表
下面的代码将工作簿中工作表的指定区域复制到名为“合并”的工作表中，与前面介绍的内容不同的是，这段代码使用公式将工作表指定区域链接到“合并”工作表相应的单元格中，这样当源工作表单元格中的值改变时，“合并”工作表中相应单元格的值也相应发生改变。示例工作簿下载：

1、在模块窗口输入下列代码：

Sub Summary_All_Worksheets_With_Formulas()
    Dim Sh As Worksheet
    Dim Newsh As Worksheet
    Dim myCell As Range
    Dim ColNum As Integer
    Dim RwNum As Long
    Dim Basebook As Workbook
 
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
 
    '如果"合并"工作表存在则删除
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("合并").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
 
    '添加一个名为"合并"的工作表
    Set Basebook = ThisWorkbook
    Set Newsh = Basebook.Worksheets.Add
    Newsh.Name = "合并"
 
    '链接的第一个工作表的数据将放置在第2行
    RwNum = 1
 
    For Each Sh In Basebook.Worksheets
        If Sh.Name <> Newsh.Name And Sh.Visible Then
            ColNum = 1
            RwNum = RwNum + 1
            '在列A复制工作表名称
            Newsh.Cells(RwNum, 1).Value = Sh.Name
 
            For Each myCell In Sh.Range("A1,D5:E5,G10")    '<--可以修改为实际的区域
                ColNum = ColNum + 1
                Newsh.Cells(RwNum, ColNum).Formula = _
                "='" & Sh.Name & "'!" & myCell.Address(False, False)
            Next myCell
 
        End If
    Next Sh
 
    Newsh.UsedRange.Columns.AutoFit
 
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

其中，“合并”工作表的A列用来放置源工作表的名称，从B列开始放置所复制的数据（实际上与源工作表中相应的单元格链接）。您可以将代码中的

Sh.Range("A1,D5:E5,G10")

修改为您自已希望复制的单元格区域。
注：您可以使用下面的代码在“合并”工作表的第一行添加标题：

'添加标题
Newsh.Range("B1:E1").Value = Array("header1", "header2", "header3", "header4")

当然，上述语句是针对本示例添加了4个标题，您可以按照需要添加更多的标题。
此外，也可以在已经存在的工作表中合并其它工作表的数据，找到上面示例代码中的下列语句：

'如果"合并"工作表存在则删除
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("合并").Delete
On Error GoTo 0
Application.DisplayAlerts = True
 
'添加一个名为"合并"的工作表
Set Basebook = ThisWorkbook
Set Newsh = Basebook.Worksheets.Add
Newsh.Name = "合并"

使用下面的代码替换：

Set Basebook = ThisWorkbook
Set Newsh = Basebook.Worksheets("工作表名称") '修改为放置数据的工作表名称
Newsh.Rows("2:" & Newsh.Rows.Count).Clear

这段代码首先清除已存在的内容，以保证数据更新，在此假设第1行是标题行，因此没有清除第1行的内容。
小结
本文介绍了几段代码示例，可以用于合并所有工作表或指定的工作表中的数据到某汇总工作表。

相关文章

标签：, ,
分类目录： VBA  |  评论 (RSS)  |  Trackback  | 3,156 次阅读
emoticons
;-):|:x:twisted::smile::shock::sad::roll::razz::oops::o:mrgreen::lol::idea::grin::evil::cry::cool::arrow::???::?::!:

2 条评论

  1. 粉丝 说：
    2009年05月27日于2:29 下午

    昨天评论没啦啊 嘿嘿

  2. 粉丝 说：
    2009年05月8日于6:54 下午

    谢谢 再来学习

发表评论