同一工作簿下合并多工作表（1）

lzwubin

解决问题为最终目的！
        各月的销售记录、各班的学生成绩、各分支机构的人员档案信息、各分支机构的缴费基数表，这些数据常在EXCEL工作表中储存，常需要把这些记录合并到一起，进行进一步的分析、利用。
        合并工作表记录，是数据业务中常见的业务。但如果采用一个表一个表的复制、粘贴，工作量大。
        现以一个企业集团所属企业养老保险缴费基数核定表为例进行说明。
        一、 企业养老保险缴费核定表表样：









二、汇总表表样：


三、通过两个按钮，分别指定宏。在EXCEL VBA环境中插入两个模块，图示、代码如下：



Sub hebing()
'把各单位缴费基数核定表合工到“汇总”工作表中
Rows("2:65536").Clear   '删除所有记录
Dim sht As Worksheet, xrow As Integer, rng As Range
For Each sht In Worksheets   ‘遍历工作表
    If sht.Name <> ActiveSheet.Name Then
       Set rng = Range("a65536").End(xlUp).Offset(1, 0) ‘获得A列第一个空单元格
       xrow = sht.Range("a1").CurrentRegion.Rows.Count - 1  ' 获得分表中的记录条数
       sht.Range("a2").Resize(xrow, 10).Copy rng  '复制记录到汇总表
    End If
Next
End Sub

Sub 清除()
Rows("2:65536").Clear
End Sub

四、执行后结果


代码执行后，如上表。这里是以三个单位的工作表数据为例，如果是几百个工作表，速度也是很快的。最后只需要把序号重新排一下，就可以了。

lzwubin

[url=][/url]结合上文，在网上又找到一例，把同一工作簿下的工作表合并成另外一个新的工作簿，默认文件名为Book1.xls。[url=][/url][url=][/url][url=][/url][url=][/url][url=][/url]大家体会。


代码如下：
Option Explicit
Sub hebing4()
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Sheets(1).Copy
    Dim i As Integer
    With wb
        For i = 2 To 3
            .Sheets(i).Range("a2:m" & .Sheets(i).[a65536].End(3).Row).Copy ActiveSheet.[a65536].End(3).Offset(1)
        Next
    End With
End Sub

大致分析如下：
Option Explicit 要求变量声明
定义变量，初始化变量，然后复制Sheet1。
设置循环结构。
For i = 2 To 3，如果是10个工作表，就改为10。
.Sheets(i).Range("a2:m" & .Sheets(i).[a65536].End(3).Row).Copy ActiveSheet.[a65536].End(3).Offset(1)
这句是复制单元格区域的语句。基本的格式是：源单元格区域.copy目标单元格区域。如果要复制，请用.copy，点不能丢掉啊。
m是分表的数据最后列，我举的例子是M列，如果你的分表是K列，请修改为K。

lzwubin

结合上文，同一工作簿下合并多工作表的最简代码，仍是两个模块，代码分别如下：

Sub hebing()
For Each st In Worksheets
    If st.Name <> ActiveSheet.Name Then st.UsedRange.Offset(1, 0).Copy [a65536].End(xlUp).Offset(1, 0)
Next
End Sub

Sub 清除()
  Rows("2:65536").Clear
End Sub

不学不知道，一学吓一跳。学一点EXCEL VBA,绝对有好处！

liuhaoqin1988

图片没上好，都看不到

a296837698

..图片看不到，防盗链了

lzwubin

a296837698 发表于 2014-3-17 00:03
..图片看不到，防盗链了

业务不熟！原谅！图片处理好了。

lzwubin

图片处理好了！

472285981

Sub hebing()
For Each st In Worksheets
    If st.Name <> ActiveSheet.Name Then st.UsedRange.Offset(1, 0).Copy [a65536].End(xlUp).Offset(1, 0)
Next
End Sub
这个是从第二行开始的  我的所有sheet第一行不见了，可以修改么

18688235083

http://club.excelhome.net/forum. ... p;page=1#pid7701023
求高手改成sql、优化读取速度和透视表刷新速度

蔡花花

lzwubin 发表于 2014-3-16 23:48
结合上文，同一工作簿下合并多工作表的最简代码，仍是两个模块，代码分别如下：

Sub hebing()

写得太好了。