合并不同文件夹下相同名称的工作簿内的工作表到同一工作表

renne_yo · 发表于 2017-2-22 09:20

各位老师们，因工作需要，需将不同文件夹下的相同名称的工作簿合并成一个工作簿，工作簿内的工作表也按照同一表名合并（只保留标题）。由于文件数量过多，复制粘贴很耗时间。我查了很多论坛上类似的合并方法，可验证结果无法得到我需求的效果，程序总是运行出错中断，比如copy语句无法调用，弹出“shee1$”定义错误等等问题。我又不会修改，只能求助大家。附件中有各个不同文件名的文件夹，可打开后里面有三张相同名字的表格，需要将各个文件夹内同名的表格复制黏贴合并到一张表格中。比如将各个文件夹内所有叫“宁德凌晨2-5点违规运营车辆”合并成一张，“宁德市超速报警统计报表”合并成另一张。由于附件限制只能上传部分文件数据，麻烦各位老师帮忙看看，调试的结果可以运用到更多类似的文件中，谢谢！

liulang0808 · 发表于 2017-2-22 09:35

http://club.excelhome.net/thread-1258425-1-1.html
有相关遍历资料供参考

renne_yo · 发表于 2017-2-22 09:59

liulang0808 发表于 2017-2-22 09:35
http://club.excelhome.net/thread-1258425-1-1.html
有相关遍历资料供参考

谢谢，这个我会好好看看，但是好像跟我需要解决的问题没多大关系。具体见附件同名表格的合并，这点很伤脑筋。

kldxlb · 发表于 2017-2-22 11:54

Sub 合并同名表()
Dim FolderName As String, FileName As String
Dim FolderColl As New Collection, dicFile As Object
Set dicFile = CreateObject("scripting.dictionary")
Dim wb模板 As Workbook, wb As Workbook
Dim 模板 As Boolean
FolderName = Dir(ThisWorkbook.Path & "\*", vbDirectory)
Do While FolderName <> ""
If FolderName <> ".." And FolderName <> "." And InStr(FolderName, ".xls") = 0 Then
FolderColl.Add FolderName
End If
FolderName = Dir
Loop
For i = 1 To FolderColl.Count
FileName = Dir(ThisWorkbook.Path & "" & FolderColl.Item(i) & "\*")
Do While FileName <> ""
dicFile(FolderColl.Item(i) & "" & FileName) = FileName
FileName = Dir
Loop
Next
arr = dicFile.keys
Application.DisplayAlerts = False
For i = 1 To dicFile.Count
Debug.Print dicFile.Item(arr(i - 1))
For j = 1 To i - 1
If dicFile.Item(arr(i - 1)) = dicFile.Item(arr(j - 1)) Then
模板 = False
Exit For
Else
模板 = True
End If
Next
If 模板 Or i = 1 Then
Set wb模板 = Workbooks.Open(ThisWorkbook.Path & "" & arr(i - 1))
wb模板.SaveAs ThisWorkbook.Path & "\汇总" & wb模板.Name
r = wb模板.Sheets(1).Range("A" & wb模板.Sheets(1).Rows.Count).End(xlUp).Row + 1
For k = i + 1 To dicFile.Count
If "汇总" & dicFile.Item(arr(k - 1)) = wb模板.Name Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "" & arr(k - 1))
endrow = wb.Sheets(1).Range("A" & wb.Sheets(1).Rows.Count).End(xlUp).Row
wb.Sheets(1).Rows("2:" & endrow).Copy
wb模板.Activate
wb模板.Sheets(1).Rows(r).Select
ActiveSheet.Paste
wb.Close
r = r + endrow - 1
End If
Next
wb模板.Save
wb模板.Close
End If
Next
Application.DisplayAlerts = True
End Sub

复制代码

renne_yo · 发表于 2017-2-22 14:50

kldxlb 发表于 2017-2-22 11:54

谢谢您的回复，直接看代码不明白，可否附上附件。

kldxlb · 发表于 2017-2-22 15:10

renne_yo 发表于 2017-2-22 14:50
谢谢您的回复，直接看代码不明白，可否附上附件。

直接运行宏就可以了

renne_yo · 发表于 2017-2-22 17:03

kldxlb 发表于 2017-2-22 15:10
直接运行宏就可以了

哇，太棒了，基本达到我的预期效果。又添加了几个文件夹试验，结果很不错，居然还能区分同名的03版本和高级版本excel表格，太赞了。有点瑕疵还是要提下，合并得到的表格里空值多，如果文件量大，可能一个表格装不下。预期的效果是合并同名表格保留第一个表格标题栏，其他工作簿复制标题栏以下内容。总之能得到这样的效果我已经很开心了，谢谢你，O(∩_∩)O

乐乐2006201505 · 发表于 2017-2-22 23:02

你试试，应该达到了你的要求，表格格式（主要是表头位置）不一致，命名不规范（宁德市与宁德。有文件夹有个2-5点的那个文件，必须把文件名中的宁德市改为宁德，否则不能提取该表数据），所以处理起来比较困难。不过花了4小时（因为我也是VBA小白），总算解决了。

renne_yo · 发表于 2017-2-23 09:54

乐乐2006201505 发表于 2017-2-22 23:02
你试试，应该达到了你的要求，表格格式（主要是表头位置）不一致，命名不规范（宁德市与宁德。有文件夹有个 ...

首先谢谢你的答复。根据你提供的宏文件，换了其他文件测试了好几遍，得到的结果很令人欣喜，确实是我理想中的效果（由于时间关系，还没测试大量的文件）。根据测试结果提几点问题：1.运行完宏跳出一个窗体，每每总是显示不同的数值，比如“116.28125”，“66.28516”，“72.18946”，“71.01563”，这些数值是什么含义?出现这个窗体是表示程序运行结束了吗？
2.命名不规范导致文件无法提取，这个问题有点棘手，我之前还没想到这点。由于这些文件是其他人提供，可能粗心疏忽而出现文件名不同的情况。特别是大量文件，难以做到打开一个个文件夹去确认文件名是否全都一致。虽然程序很好但拘束性强，根据实际情况可能用不了。
若能稍加改动程序，比如同名文件的模糊匹配，增加此程序的灵活性，运用到更多类似问题中就很实用了。再次谢谢你的回答，我会好好研究的（现在可能没那能力改程序，基本VBA语言都不知，只能运用结果）。

乐乐2006201505 · 发表于 2017-2-23 10:07

本帖最后由乐乐2006201505 于 2017-2-23 10:10 编辑

renne_yo 发表于 2017-2-23 09:54
首先谢谢你的答复。根据你提供的宏文件，换了其他文件测试了好几遍，得到的结果很令人欣喜，确实是我理想 ...

第一个问题，是完成汇总时间，你可以去掉，也可以作为代码速度的测试；
第二个问题，我试了一下，模糊匹配好像效果不是很好，用了like进行匹配，暂时未成功，后边我再考虑考虑，当然还可以通过先重命名统一文件名来实现想要的结果。另外你说到程序局限性的问题，作为VBA代码来说，已经做得可以了，你也可以求助其他高手帮你解决。

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

[求助] 合并不同文件夹下相同名称的工作簿内的工作表到同一工作表

评分

评分