如何将多个不同名称的文件夹中的相同名称的工作簿进行合并，形成新的工作簿。

opiona

vince鑫15 发表于 2016-5-31 15:49
老师您好，求助~~具体看9楼

1. 
   
2. '*********************************
   
3. '*******  北极狐工作室出品  ******
   
4. '*******  QQ：14885553      ******
   
5. '*********************************
   
6. 
   
7. Sub Opiona()
   
8. 
   
9. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
10. Application.ScreenUpdating = False '//关闭屏幕刷新
    
11. Application.DisplayAlerts = False '//关闭系统提示
    
12. t = Timer   '//开始时间
    
13.    
    
14.     Kill ThisWorkbook.Path & "\需要得到的结果.xlsx"  '//先删除以前的结果
    
15.    
    
16.     FileArr = FileAllArr(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, True, False)   '//获得文件列表，见函数解释
    
17.     Set WB = Workbooks.Add  '新建一个工作簿
    
18.     Set SHX = WB.Sheets(1)
    
19.    
    
20.     For I = 0 To UBound(FileArr)
    
21.         Rem  '//工作簿的问题，无法使用SQL，而且还要以修复形式打开
    
22.         Set WBOPEN = Workbooks.Open(Filename:=FileArr(I), CorruptLoad:=xlExtractData)
    
23.         Set SHOPEN = WBOPEN.Sheets(1)
    
24.         If I = 0 Then '//粘贴标题
    
25.             SHOPEN.Range("A1:CZ1").Copy SHX.Range("A1")
    
26.         End If
    
27.         IROW = SHX.Range("A1048576").End(3).Row + 1
    
28.         LASTROW = SHOPEN.Range("A1048576").End(3).Row
    
29.         SHOPEN.Range("A2:CZ" & LASTROW).Copy SHX.Range("A" & IROW)  '//复制数据，假设标题顺序一致
    
30.         
    
31.         WBOPEN.Close False
    
32.     Next I
    
33. 
    
34.     WB.SaveAs ThisWorkbook.Path & "\需要得到的结果.xlsx"    '另存为指定文件名
    
35.     WB.Close True
    
36.    
    
37. Application.ScreenUpdating = True '//恢复屏幕刷新
    
38. Application.DisplayAlerts = True '//恢复系统提示
    
39. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
40. End Sub

复制代码

opiona

汇总.rar (432.32 KB, 下载次数: 143)

2016-6-1 09:08 上传

点击文件名下载附件

天道酬勤y

跟我的需求好像 可是不会

天道酬勤y

opiona 发表于 2016-6-1 09:08

能看下我这个吗
http://club.excelhome.net/thread-1328772-1-1.html

O19801126

opiona 发表于 2016-6-1 09:08

老师
能帮我解决一下么，2个问题

拆分
http://club.excelhome.net/thread-1458151-1-1.html

合并
http://club.excelhome.net/thread-1458149-1-1.html

Strive_TL

opiona 发表于 2016-6-1 09:08

老师你好，能帮忙看下这个需求吗，和这个雷同，每天要重复几十个表格的操作http://club.excelhome.net/forum. ... 3D1&page=1&