同文件夹下所有工作薄的工作表按子表名包含的相同字眼（同类别）汇总到本工作薄

zhaogang1960 · 发表于 2014-5-11 22:08

neke520 发表于 2014-5-11 21:49
赵版主，附件只改了你在6楼测试附件的第一个工作薄里的子表名称，就统计不出结果

Sub Macro1()
Dim MyPath$, MyName$, sh As Worksheet, arr$(), i&, r&, wb As Workbook
Application.ScreenUpdating = False
ReDim arr(2 To Worksheets.Count)
For i = 2 To Worksheets.Count
With Worksheets(i)
.UsedRange.Offset(3).Clear
arr(i) = .Name
End With
Next
Set wb = ThisWorkbook
r = Rows.Count
MyPath = ThisWorkbook.Path & ""
MyName = Dir(MyPath & "*.xlsx")
Do While MyName <> ""
With GetObject(MyPath & MyName)
For Each sh In .Sheets
For i = 2 To UBound(arr)
If InStr(sh.Name, arr(i)) Then
sh.UsedRange.Offset(3).Copy wb.Worksheets(arr(i)).Cells(r, 1).End(xlUp).Offset(1)
Exit For
End If
Next
Next
.Close False
End With
MyName = Dir
Loop
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2014-5-11 22:09

请测试附件

neke520 · 发表于 2014-5-12 22:24

zhaogang1960 发表于 2014-5-11 22:09
请测试附件

赵版，
当要合并的工作簿有超链接时就有这种 QQ截图-超链接.jpg

，能否直接不更新跳过？或者把有公式的单元格直接取数值？
另外如果要合并的工作薄有超链接时运算特别慢，有什么办法解决么？

zhaogang1960 · 发表于 2014-5-12 22:30

neke520 发表于 2014-5-12 22:24
赵版，
当要合并的工作簿有超链接时就有这种，能否直接不更新跳过？或者把有公式的单元格直接取数值？
...

请上传这种工作簿分析一下

neke520 · 发表于 2014-5-12 23:07

zhaogang1960 发表于 2014-5-12 22:30
请上传这种工作簿分析一下

新建文件夹 (2).rar (171.71 KB, 下载次数: 7)

zhaogang1960 · 发表于 2014-5-12 23:23

neke520 发表于 2014-5-12 23:07

Sub Macro1()
Dim MyPath$, MyName$, sh As Worksheet, arr$(), i&, r&, wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False '新加
ReDim arr(2 To Worksheets.Count)
For i = 2 To Worksheets.Count
With Worksheets(i)
.UsedRange.Offset(3).Clear
arr(i) = .Name
End With
Next
Set wb = ThisWorkbook
r = Rows.Count
MyPath = ThisWorkbook.Path & ""
MyName = Dir(MyPath & "*.xlsx")
' Application.AskToUpdateLinks = False'如果测试还出现请启用这一句
Do While MyName <> ""
With GetObject(MyPath & MyName)
For Each sh In .Sheets
For i = 2 To UBound(arr)
If InStr(sh.Name, arr(i)) Then
sh.UsedRange.Offset(3).Copy wb.Worksheets(arr(i)).Cells(r, 1).End(xlUp).Offset(1)
Exit For
End If
Next
Next
.Close False
End With
MyName = Dir
Loop
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2014-5-12 23:28

请看附件

新建文件夹 (2).rar (302.41 KB, 下载次数: 80)

neke520 · 发表于 2014-5-12 23:34

zhaogang1960 发表于 2014-5-12 23:23

Application.DisplayAlerts = False '新加

Application.ScreenUpdating = True

请教赵版前我试过加这个语句，还是出现。我先试试这个

neke520 · 发表于 2014-5-13 00:26

本帖最后由 neke520 于 2014-5-13 00:28 编辑

zhaogang1960 发表于 2014-5-12 23:28
请看附件

遇到了个怪事，有很多的工作簿会出现这个错误 QQ截图1.jpg

,但是把报错的那个工作薄单独统计就没问题

重新统计了1-3月耗时还是蛮长的如果全年数据估计要死机。赵版，所有表工作薄能根据C列的时间按月合并就更好

新建文件夹--按月.rar (302.12 KB, 下载次数: 11)

zhaogang1960 · 发表于 2014-5-13 00:33

neke520 发表于 2014-5-13 00:26
遇到了个怪事，有很多的工作簿会出现这个错误,但是把报错的那个工作薄单独统计就没问题

经测试没有发现问题，请上传有问题的工作簿

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