利用VBA条件提取合并多个表内容

fujianfei686

附件里有3个表，想达到“条件合并”里的效果，请问哪位老师能帮忙看一下看了这篇百度经验https://jingyan.baidu.com/article/64d05a027cf909de55f73bc3.html，很难重新编写，请大神赐教

chaohuahch

遍历工作簿，然后用字典，就可以解决了。

fujianfei686

chaohuahch 发表于 2018-9-8 07:35
遍历工作簿，然后用字典，就可以解决了。

找到一篇帖子，大神的代码可以学习下，不知道怎么用字典 怎么只复制“识别码”一列？

1. Sub 汇总()
   
2. Application.ScreenUpdating = False '防止屏幕闪烁
   
3. Dim wb As Excel.Workbook '定义变量
   
4. Sheet1.Rows("2:60000") = "" '清除原数据
   
5. f = Dir(ThisWorkbook.Path & "\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
   
6. Do While f <> "" '在目录中循环
   
7. If f <> ThisWorkbook.Name Then&#160;&#160;'如果不是打开的工作簿
   
8. Set wb = Workbooks.Open(ThisWorkbook.Path & "" & f) '依次打开目录工作薄
   
9. wb.Worksheets(1).UsedRange.Offset(1).Copy ThisWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1) '拷贝数据
   
10. ThisWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(wb.Worksheets(1).UsedRange.Rows.Count - 1, 1) = Split(wb.Name, ".")(0) '文件名称
    
11. &#160; &#160; wb.Close False '关闭打开的工作薄
    
12. &#160; &#160; End If
    
13. &#160; &#160; f = Dir '寻找下一个文件
    
14. &#160; &#160; Loop '结束循环
    
15. &#160; &#160; Application.ScreenUpdating = True '
    
16. End Sub

复制代码

fujianfei686

chaohuahch 发表于 2018-9-8 07:35
遍历工作簿，然后用字典，就可以解决了。

多谢

找到一篇帖子[url]http://club.excelhome.net/thread-1333133-1-1.html[/url]，大神的代码可以学习下，不知道怎么用字典 怎么只复制“识别码”一列？

1. Sub 汇总()
   
2. Application.ScreenUpdating = False '防止屏幕闪烁
   
3. Dim wb As Excel.Workbook '定义变量
   
4. Sheet1.Rows("2:60000") = "" '清除原数据
   
5. f = Dir(ThisWorkbook.Path & "\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
   
6. Do While f <> "" '在目录中循环
   
7. If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
   
8. Set wb = Workbooks.Open(ThisWorkbook.Path & "" & f) '依次打开目录工作薄
   
9. wb.Worksheets(1).UsedRange.Offset(1).Copy ThisWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1) '拷贝数据
   
10. ThisWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(wb.Worksheets(1).UsedRange.Rows.Count - 1, 1) = Split(wb.Name, ".")(0) '文件名称
    
11.     wb.Close False '关闭打开的工作薄
    
12.     End If
    
13.     f = Dir '寻找下一个文件
    
14.     Loop '结束循环
    
15.     Application.ScreenUpdating = True '
    
16. End Sub

复制代码

abc123281

代码仅供测试参考


条件合并123.rar (26.6 KB, 下载次数: 22)

2018-9-8 08:00 上传

点击文件名下载附件

约定的童话

abc123281 发表于 2018-9-8 08:00
代码仅供测试参考

代码应该还可以优化吧？

abc123281

既然你知道还可以优化    请指教

fujianfei686

abc123281 发表于 2018-9-8 08:00
代码仅供测试参考

多谢多谢，自己又修改了下，字典好难学