帮忙这个表格里的所有sheet合并一个sheet里，并保存每个sheet的命名

y3377y

帮忙这个表格里的所有sheet合并一个sheet里，如果能把每个sheet对应的日期也带上就更好了，谢谢大家

changhong8

表的格式不太一样啊，中间的表字段多了几列

chxw68

1. Sub tet()
   
2.   Dim r%, i%
   
3.   Dim ws As Worksheet
   
4.   Dim ws0 As Worksheet
   
5.   With Worksheets("sheet1")
   
6.     .UsedRange.Offset(1, 0).Clear
   
7.   End With
   
8.   Set ws0 = Worksheets("sheet1")
   
9.   For Each ws In Worksheets
   
10.     If ws.Name <> "Sheet1" Then
    
11.       With ws
    
12.         With ws0
    
13.           r0 = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.         End With
    
15.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
16.         .Range("a2:e" & r).Copy ws0.Cells(r0 + 1, 2)
    
17.         With ws0
    
18.           .Cells(r0 + 1, 1).Resize(r - 1, 1) = ws.Name
    
19.         End With
    
20.       End With
    
21.     End If
    
22.   Next
    
23. End Sub
    

复制代码

chxw68

详见附件。

changhong8

6.26、6.27、7.9这三张表多出来一部分内容，如果需要的话你自己单独处理吧，详见附件

y3377y

changhong8 发表于 2017-8-12 10:44
表的格式不太一样啊，中间的表字段多了几列

是的，中间有一个表格不太一样，谢谢啦

y3377y

changhong8 发表于 2017-8-12 10:52
6.26、6.27、7.9这三张表多出来一部分内容，如果需要的话你自己单独处理吧，详见附件

好的，谢谢你，还有个傻问题请教你，怎么送花呀

y3377y

chxw68 发表于 2017-8-12 10:49
详见附件。

谢谢老师，虽然完全看不懂代码

chxw68

y3377y 发表于 2017-8-12 16:13
好的，谢谢你，还有个傻问题请教你，怎么送花呀

积分满20分以后才能送花，努力吧！