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

luocong007 · 发表于 2018-4-1 17:40

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

abc123281 · 发表于 2018-4-1 18:11

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

abc123281 · 发表于 2018-4-1 20:15

仅供参考

Sub 汇总abc123()
Dim wb As Workbook
Dim ws As Worksheet
Dim arr, brr(1 To 10000, 1 To 54)
Dim mypath$, myname$
Application.DisplayAlerts = False
Application.ScreenUpdating = False
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.xls*")
Do While myname <> ""
If myname <> ThisWorkbook.Name Then
Set wb = GetObject(mypath & myname)
With wb
For Each ws In .Worksheets
With ws
If .[a4] <> "" Then
arr = .[a4].CurrentRegion
For i = 5 To UBound(arr)
If IsNumeric(arr(i, 1)) Then
n = n + 1
For j = 1 To UBound(arr, 2)
brr(n, j) = arr(i, j)
Next
End If
Next
End If
End With
Next
wb.Close False
End With
End If
myname = Dir()
Loop
With Worksheets("汇总")
.[a3].Resize(UBound(brr), 54) = brr
.UsedRange.Borders.LineStyle = 1
rw = .[b65536].End(3).Row
For i = 3 To rw
If .Cells(i, 2) <> "" Then
.Cells(i, 1) = i - 2
End If
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "汇总完成，本次共汇总了" & n & "条信息，请核查！"
End Sub

复制代码

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

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

luocong007 · 发表于 2018-4-2 11:04

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

100个赞，太感谢了。

lrh788 · 发表于 2018-4-2 18:32

学习了！！！！！

ardu95 · 发表于 2018-4-2 19:29

学习学习

jjmysjg · 发表于 2018-4-2 19:33

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

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

lsc900707 · 发表于 2018-4-2 20:05

本帖最后由 lsc900707 于 2018-4-2 20:08 编辑

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

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

shchint · 发表于 2023-3-23 12:33

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

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

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分