求VBA写将子文件夹相同名字工作簿的内容，合并起来

feisdfei

说明：1、有多个子文件夹；
2、每个工作簿中只有一个sheet，但是不同的子文件夹里的工作簿名字可能会一样；
3、把所有名字一样的工作簿内容合并起来，只保留一个标题，并且将这个工作簿的名字后面加上 "-new"后保存到指定文件夹内；
4、其它所有不同的名字工作簿内容不变，但与上面新保存的工作簿（就是名字加“-new”的工作簿）放一起；

小弟VBA菜鸟，烦请大神们指点下，先谢过了！

opiona

1. Sub Opiona()
   
2. 
   
3. '禁止系统刷屏?触发其他事件等
   
4. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
5. Application.ScreenUpdating = False '//关闭屏幕刷新
   
6. Application.DisplayAlerts = False '//关闭系统提示
   
7. Application.EnableEvents = False  '//禁止触发其他事件
   
8. t = Timer   '//开始时间
   
9. 
   
10.     StrNames = "|"   '//记录已经汇总的文件名
    
11.     Path来源 = ThisWorkbook.Path & "\数据"
    
12.     Path结果 = ThisWorkbook.Path & "\结果"
    
13. 
    
14.     Set FSO = CreateObject("Scripting.FileSystemObject")
    
15.     If FSO.FolderExists(Path结果) = True Then
    
16.         FSO.GetFolder(Path结果).Delete   '//删除文件夹
    
17.     End If
    
18.    
    
19.     FileArr = FileAllArr(Path来源, "*.xls?", ThisWorkbook.Name, True, False)
    
20.     MkDir Path结果    '//创建文件夹
    
21.    
    
22.     For I = 0 To UBound(FileArr)
    
23.    
    
24.         STRNEW = GetPathFromFileName(FileArr(I))
    
25.         If InStr(StrNames, "|" & STRNEW & "|") = 0 Then  '//还未处理此文件名的文件
    
26.             ReDim ARX(1 To 1)
    
27.             ARX(1) = ""
    
28.             INTX = 1
    
29.             For X = 0 To UBound(FileArr)
    
30.                 If STRNEW = GetPathFromFileName(FileArr(X)) Then
    
31.                     ARX(INTX) = FileArr(X)
    
32.                     INTX = INTX + 1
    
33.                     ReDim Preserve ARX(1 To INTX)
    
34.                 End If
    
35.             Next X
    
36.             
    
37.             
    
38.             If INTX > 2 Then  '//说明有重复名
    
39.             
    
40.                 Set WB = Workbooks.Open(ARX(1))
    
41.                 Set SHW = Worksheets(1) '//假设所有数据多在第一个表中,而且所有工作簿，此工作表名相同
    
42.                
    
43.                 For X = 2 To UBound(ARX) - 1
    
44.                     Str_coon = "HDR=yes';Data Source =" & ARX(X)     '//OFFICE2003，2007 通用
    
45.                     StrSQL = "SELECT * FROM [" & SHW.Name & "$]"
    
46.                     SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
47.                     
    
48.                     IROW = SHW.Range("A65536").End(3).Row + 1
    
49.                     SHW.Range("A" & IROW).Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
    
50.                 Next X
    
51.                 WB.SaveAs Filename:=Path结果 & "" & GetPathFromFileName(ARX(1)) & "_NEW.xlsx"
    
52.                 WB.Close True
    
53.             Else
    
54.                 PathNew = Path结果 & "" & GetPathFromFileName(FileArr(I), True)
    
55.                 FileCopy FileArr(I), PathNew
    
56.             End If
    
57.             StrNames = StrNames & STRNEW & "|"
    
58.         End If
    
59.     Next
    
60. 
    
61. Application.EnableEvents = True  '//  '//恢复触发其他事件
    
62. Application.ScreenUpdating = True '//恢复屏幕刷新
    
63. Application.DisplayAlerts = True '//恢复系统提示
    
64. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
65. End Sub

复制代码

opiona

相同表汇总.rar (66.49 KB, 下载次数: 93)

2016-9-4 12:23 上传

点击文件名下载附件

feisdfei

opiona 发表于 2016-9-4 12:24

大佬，太给力了，跪谢！！

feisdfei

opiona 发表于 2016-9-4 12:23

抱歉，里面我有点疏忽了，如果我的数据源是.csv格式的，导出的结果也要.csv格式的，请问怎么改，谢谢！

雪白透亮

你把大神代码中 WB.SaveAs Filename:=Path结果 & "\" & GetPathFromFileName(ARX(1)) & "_NEW.xlsx“最后的扩展名改了就行了吧

opiona

上传附件，看看吧！

feisdfei

opiona 发表于 2016-9-6 08:15
上传附件，看看吧！

太高端了，发现自己改不了，烦请大神帮忙看看，谢谢！

feisdfei

雪白透亮 发表于 2016-9-6 02:22
你把大神代码中 WB.SaveAs Filename:=Path结果 & "\" & GetPathFromFileName(ARX(1)) & "_NEW.xlsx“最后的 ...

这样改只能把合并的表改成csv格式，我现在是数据源也是csv格式，导出的结果也要csv格式

opiona

feisdfei 发表于 2016-9-6 09:29
这样改只能把合并的表改成csv格式，我现在是数据源也是csv格式，导出的结果也要csv格式

1. Sub Opiona()
   
2. 
   
3. '禁止系统刷屏?触发其他事件等
   
4. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
5. Application.ScreenUpdating = False '//关闭屏幕刷新
   
6. Application.DisplayAlerts = False '//关闭系统提示
   
7. Application.EnableEvents = False  '//禁止触发其他事件
   
8. t = Timer   '//开始时间
   
9. 
   
10.     BOOL标题 = True   '//是否有标题行，如果有，只能占一行
    
11.    
    
12.     StrNames = "|"   '//记录已经汇总的文件名
    
13.     Path来源 = ThisWorkbook.Path & "\数据"
    
14.     Path结果 = ThisWorkbook.Path & "\结果"
    
15. 
    
16.     Set FSO = CreateObject("Scripting.FileSystemObject")
    
17.     If FSO.FolderExists(Path结果) = True Then
    
18.         FSO.GetFolder(Path结果).Delete   '//删除文件夹
    
19.     End If
    
20.    
    
21.     FileArr = FileAllArr(Path来源, "*.csv", ThisWorkbook.Name, True, False)
    
22.     MkDir Path结果    '//创建文件夹
    
23.    
    
24.     For I = 0 To UBound(FileArr)
    
25.    
    
26.         STRNEW = GetPathFromFileName(FileArr(I))
    
27.         If InStr(StrNames, "|" & STRNEW & "|") = 0 Then  '//还未处理此文件名的文件
    
28.             ReDim ARX(1 To 1)
    
29.             ARX(1) = ""
    
30.             INTX = 1
    
31.             For X = 0 To UBound(FileArr)
    
32.                 If STRNEW = GetPathFromFileName(FileArr(X)) Then
    
33.                     ARX(INTX) = FileArr(X)
    
34.                     INTX = INTX + 1
    
35.                     ReDim Preserve ARX(1 To INTX)
    
36.                 End If
    
37.             Next X
    
38.             
    
39.             
    
40.             If INTX > 2 Then  '//说明有重复名
    
41.             
    
42.                 Set WB = Workbooks.Add
    
43.                 Set SHW = Worksheets(1) '//假设所有数据多在第一个表中,而且所有工作簿，此工作表名相同
    
44.                
    
45.                 For X = 1 To UBound(ARX) - 1
    
46.                     
    
47.                     Set WB1 = Workbooks.Open(ARX(X))
    
48.                     Set SHW1 = Worksheets(1) '//假设所有数据多在第一个表中,而且所有工作簿，此工作表名相同
    
49.                     
    
50.                     If BOOL标题 = True Then
    
51.                         If X = 1 Then  '//粘贴标题
    
52.                             SHW1.Range("A1:AZ1").Copy SHW.Range("A1")
    
53.                         End If
    
54.                         Set tbl = SHW1.Range("A1").CurrentRegion
    
55.                         SQLARR = tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count)  '//去掉标题的区域
    
56.                     Else
    
57.                         SQLARR = SHW1.Range("A1").CurrentRegion
    
58.                     End If
    
59.                     
    
60.                     IROW = SHW.Range("A65536").End(3).Row + 1
    
61.                     SHW.Range("A" & IROW).Resize(UBound(SQLARR, 1), UBound(SQLARR, 2)) = SQLARR
    
62.                     
    
63.                     WB1.Close False
    
64.                 Next X
    
65.                
    
66.                 WB.SaveAs Filename:=Path结果 & "" & GetPathFromFileName(ARX(1)) & "_NEW.csv", FileFormat:=xlCSV
    
67.                 WB.Close True
    
68.             Else
    
69.                 PathNew = Path结果 & "" & GetPathFromFileName(FileArr(I), True)
    
70.                 FileCopy FileArr(I), PathNew
    
71.             End If
    
72.             StrNames = StrNames & STRNEW & "|"
    
73.         End If
    
74.     Next
    
75. 
    
76. Application.EnableEvents = True  '//  '//恢复触发其他事件
    
77. Application.ScreenUpdating = True '//恢复屏幕刷新
    
78. Application.DisplayAlerts = True '//恢复系统提示
    
79. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
80. End Sub

复制代码