自动将多个工作表中的内容复制到一个表中，且随时更新

hmlyzq

如图所示

每个工作表的格式都一样
内容的宽度固定，从B列到G列
高度不一定，这个用COUNTA(B4:B1000)得出
汇总想要达到的效果如下图所示
只保留一个标题
内容只是单纯叠加，不需要进行计算

然后除此这后，以后新建新的工作表时，内容都能自动添加到汇总表中
或者对现有的工作表进行修改后，汇总表里也同样进行变化

我搜索了一整天，这个帖子的要求是最接近的，最终完成的效果也非常好

http://club.excelhome.net/forum.php?mod=viewthread&tid=958046.

但是和我的要求还是有明显区别
他是每一个工作表都分成两个部分，然后分别将两个部分汇总
我的只有一个部分，应该要比他的要求简单
但是我试图改VBA程序的时候却看不明白，不知道如何下手
不知道哪位大才能帮忙改一下吗，非常感谢
这是我的附件
工具统计.rar (17.9 KB, 下载次数: 198)

2013-7-31 21:50 上传

点击文件名下载附件

这是要求非常接近的附件
04-仪修2012年11月设备缺陷统计.rar (89.35 KB, 下载次数: 278)

2013-7-31 21:50 上传

点击文件名下载附件

Sub djk()
Dim arr(1 To 100000, 1 To 7), brr, crr(1 To 100000, 1 To 7)
Range("a4:g10000").Delete
For i = 2 To Sheets.Count
brr = Sheets(i).Range("b4").CurrentRegion
For c = 4 To UBound(brr)
If brr(c, 2) = "遗留缺陷" Then
n = c
Exit For
End If
k = k + 1
For s = 2 To UBound(brr, 2)
arr(k, 1) = k
arr(k, s) = brr(c, s)
Next
Next
For j = n + 2 To UBound(brr)
m = m + 1
For Z = 2 To 6
crr(m, 1) = m
crr(m, Z) = brr(j, Z)
Next
Next
Erase brr
Next
Range("a4").Resize(k, 7) = arr
Range("b" & k + 4 + 1) = "遗留缺陷"
Range("a" & k + 4 + 1 & ":g" & k + 4 + 1).Interior.ColorIndex = 27
g = k + 4 + 2
Range("a" & g & ":g" & g) = Range("a3:g3").Value
Range("a" & k + 4 + 3).Resize(m, 7) = crr

End Sub

hmlyzq

LangQueS 发表于 2013-7-31 22:46
代码参考：

http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=877365&pid=6005722 ...

抱歉，还是看不懂，我的VBA基础为零
我现在是复制粘贴一次，录一个宏，然后另循环试试
但是肯定达不到随时更新的效果
不知版大能否出手相助，直接把顶楼的改改

LangQueS

代码参考：

http://club.excelhome.net/forum. ... 365&pid=6005722

hmlyzq

几个小问题
一个是将序号也一并复制粘贴过来了，所以是不是应该把这句
Sheets("汇总").Range(y + 1 & ":" & y + x - 3) = Sheets(i).Range("4:" & x).Value
改成
Sheets("汇总").Range(y + 2 & ":" & y + x - 3) = Sheets(i).Range("5:" & x).Value

同样是这句话，最后的value是不是指以数值的形式粘贴？这样容易导致一些标记被系统认为是日期，以文本形式粘贴应该是什么？

不能自动执行，需要清空之后重新执行一次宏才可以，是不是在前边加一句
Range("a4:I1000").Delete就可以了

序号自动填充到最后一行要怎么写呢
rang(“A4:A”&y)=1,2,3...y{:soso_e127:}
还是非常感谢

LangQueS

hmlyzq 发表于 2013-7-31 22:53
抱歉，还是看不懂，我的VBA基础为零
我现在是复制粘贴一次，录一个宏，然后另循环试试
但是肯定达不到随 ...

试试看：

1. Sub 合并多表数据到汇总表()
   
2. Application.Calculation = xlCalculationManual       '手动重算
   
3. For i = 1 To Sheets.Count        '循环工作表
   
4.      x = Sheets(i).Columns(2).Find("*", , xlValues, , , 2).Row   '第2列最后可见非空单元行号
   
5.      y = Sheets("汇总").Columns(2).Find("*", , xlValues, , , 2).Row   '第2列最后可见非空单元行号
   
6.      Sheets("汇总").Range(y + 1 & ":" & y + x - 3) = Sheets(i).Range("4:" & x).Value    '标题行在第3行
   
7. Next
   
8. Application.Calculation = xlCalculationAutomatic    '自动重算
   
9. End Sub

复制代码

hmlyzq

拓展一下，如何将同一个文件夹下的所有工作簿的第一个工作表的内容汇总到一个新工作簿上？

wen_263

这个贴不错，正是我需要的

thb5331232

学习一下。

thb5331232

学习一下。。

hmlyzq

LangQueS 发表于 2013-7-31 23:56
试试看：

y = Sheets("汇总").Columns(2).Find("*", , xlValues, , , 2).Row   '第2列最后可见非空单元行号
这一行代码出现错误，提示下标越界