多工作簿多表汇总数据，需剔除表尾的备注信息

luocong007

菜鸟一个，希望高手帮忙，每个月要手工复制粘贴60多个工作簿的数据汇总，真的很崩溃。要实现的目的就是把各工作簿中的所有表（有些一个工作簿会有多张表）中的数据汇总到总表，有在群里搜索过很多贴，但是都不合适我这个提取的方式，由于数据源表的数据下面有很多备注信息，而我只需要提取除表头和表尾中间的数据，中间数据根据序号和人名的记录条数来提取，套用了论坛之前的代码使用后，出现每个工作簿的表头和表尾都拷贝进来了，还需手工删除。希望各位大神帮帮忙，谢谢了。  

abc123281

可以实现   晚上看看吧   
    你的每个分表的数据都是从a7单元格开始吗   格式都一样吗

abc123281

仅供参考

1. Sub 汇总abc123()
   
2. Dim wb As Workbook
   
3. Dim ws As Worksheet
   
4. Dim arr, brr(1 To 10000, 1 To 54)
   
5. Dim mypath$, myname$
   
6. Application.DisplayAlerts = False
   
7. Application.ScreenUpdating = False
   
8. mypath = ThisWorkbook.Path & ""
   
9. myname = Dir(mypath & "*.xls*")
   
10. Do While myname <> ""
    
11.    If myname <> ThisWorkbook.Name Then
    
12.       Set wb = GetObject(mypath & myname)
    
13.       With wb
    
14.         For Each ws In .Worksheets
    
15.            With ws
    
16.              If .[a4] <> "" Then
    
17.                 arr = .[a4].CurrentRegion
    
18.                 For i = 5 To UBound(arr)
    
19.                    If IsNumeric(arr(i, 1)) Then
    
20.                       n = n + 1
    
21.                       For j = 1 To UBound(arr, 2)
    
22.                          brr(n, j) = arr(i, j)
    
23.                       Next
    
24.                    End If
    
25.                 Next
    
26.              End If
    
27.            End With
    
28.          Next
    
29.         wb.Close False
    
30.       End With
    
31.     End If
    
32.    myname = Dir()
    
33. Loop
    
34. With Worksheets("汇总")
    
35. .[a3].Resize(UBound(brr), 54) = brr
    
36. .UsedRange.Borders.LineStyle = 1
    
37.   rw = .[b65536].End(3).Row
    
38.   For i = 3 To rw
    
39.     If .Cells(i, 2) <> "" Then
    
40.      .Cells(i, 1) = i - 2
    
41.     End If
    
42.   Next
    
43. End With
    
44. Application.DisplayAlerts = True
    
45. Application.ScreenUpdating = True
    
46. MsgBox "汇总完成，本次共汇总了" & n & "条信息，请核查！"
    
47. End Sub

复制代码

abc123281

多工作簿汇总abc123.rar (204.91 KB, 下载次数: 89)

2018-4-1 20:16 上传

点击文件名下载附件

luocong007

abc123281 发表于 2018-4-1 20:16

100个赞，太感谢了。

lrh788

学习了！！！！！

ardu95

学习学习                              

jjmysjg

abc123281 发表于 2018-4-1 20:15
仅供参考

没看明白，是怎么确认“备注”这个界限的

lsc900707

jjmysjg 发表于 2018-4-2 19:33
没看明白，是怎么确认“备注”这个界限的

If IsNumeric(arr(i, 1)) Then  判断第一列是否数字

shchint

abc123281 发表于 2018-4-1 20:16

老师，如果汇总表也像分表一样有表头表尾，能在汇总表的表头和表尾之间插入空行再填入数据吗？