合并当前工作簿中结构相同的多张工作表

楼主杨开科	合并当前工作簿中结构相同的多张工作表.rar Option Explicit '合并当前工作簿中结构相同的多张工作表 '重点知识点：①按索引编号引用工作表，这在循环中相当有用 _ 　　　　　　②宏表函数的应用为变量x赋值 _ 　　　　　　③Range.Copy 方法的应用，减少不必要的Select或Activate _ ④错误处理语句的应用 '恰当的空行有助于使代码更清晰、易读 Sub Union_sheet() Dim y As Integer, i As Integer, x As Long, k As String Application.ScreenUpdating = False ' 关闭屏幕更新 On Error Resume Next '如果不存在“汇总”工作表下一行代码会出现“下标越界”错误，这一句代码使其从紧随产生错误的语句的下个语句恢复运行 If Worksheets("汇总") Is Nothing Then '如果不存在“汇总”工作表 Worksheets.Add(Before:=Worksheets(1)).Name = "汇总" '在最前面插入一张工作表并命名为“汇总”,索引号为1 Else '如果存在 On Error GoTo 0 '停止在当前过程中处理错误(注意：工作簿被保护时无法移动，工作表受保护时无法清除单元格内容） Worksheets("汇总").Move Worksheets(1) '将它移动到最前面 Worksheets("汇总").Cells.ClearContents '清除单元格内容 End If y = 2 '初始化变量并赋值为2 For i = 2 To Sheets.Count '从第2张表开始循环 Sheets(i).Select '选定它 ActiveSheet.UsedRange '重置活动工作表已用区域 x = Application.ExecuteExcel4Macro("Get.Document(10)") ' 将活动工作表中已用最大行数赋值给变量x If x > 1 Then '如果不是空表才往下执行 Rows("2:" & x).Copy Sheets("汇总").Range("A" & y) '从每个不为空的表第2行起开始复制到最后一行，粘贴到汇总表中（第一行标题不复制，第一次粘贴的位置是A2单元格） y = y + x - 1 '获取下一次粘贴的起始行，若首次粘贴时x取到的值为10,则复制2:10行（共9行），从汇总表A2粘到A10，那么下一次粘贴的位置应该是y=2+10-1=11 Debug.Print y k = Sheets(i).Name '如果不是空表，则记下表名以便将该表标题复制给“汇总”表 End If Next i '对下一张表进行操作 Sheets(1).Select '选定最前面的表即“汇总”表 Sheets(k).Rows(1).Copy [A1] '将第1行标题复制到“汇总”表A1开始的位置 Cells.EntireColumn.AutoFit '自动调整列宽 Application.ScreenUpdating = True '启用屏幕更新 MsgBox "数据合并完成！", 64, "提示" End Sub
2楼海洋之星	2015你都用上了
3楼杨开科
4楼 bluexuemei	学习!
5楼西北高楼	谢谢楼主，我昨天用您的办法解决了问题，不过你的代码好像有问题： 1、小错误，4、5、6行应加'符号 2、直接使用你的合并不成功，后将第29行的 Rows("2:" & x).Copy Sheets("汇总").Range("A" & y) 前加上，Sheets(i).就好了。 3、标题的问题没解决，但实际应用中简单。顺便再问下，如何合并多工作簿了，结构也一样。呵呵，我想找现成的，感觉您的代码不错。
6楼 j5812516	XO(∩_∩)O谢谢