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

112ppp · 发表于 2014-12-10 15:16

本帖最后由 112ppp 于 2014-12-10 15:19 编辑

现有无数个文件夹，每个文件夹中有无数个名称相同的工作簿，如下图例举的“期”和“拼”两个文件夹，文件夹中都有三个相同名字的工作簿：复、特、新。（有可能文件夹还会有几个不同名称的工作簿）

现需要将这些文件夹中存在相同名称的工作簿中的表格进行合并，形成新的工作簿，工作簿名称不变。如图所示。（不相同名称的工作簿直接引入“需要得到的结果”的文件夹中。）

新合并后的每个工作簿中就存在了多个工作表，工作表名称均需按来源的文件夹名称来进行重命名。如

。

说明：新合并后的工作簿中的表格是来源于几个文件夹，则就有几个工作表。如果来源于二个文件夹，就有二个工作表，总之来源于几个文件夹新合并后的工作簿中就有几个工作表。如果仅来源于一个文件夹，工作簿中就只有一个工作表，但表中名称仍然需要更改成来源文件夹的名称。

请各位老师帮助编写个VBA，拜托了。

opiona · 发表于 2014-12-11 10:00

本帖最后由 opiona 于 2014-12-11 10:34 编辑

自定义函数见附件:

合并表格.rar (79.13 KB, 下载次数: 353)
不知道是否符合要求

'*********************************
'******* 北极狐工作室出品 ******
'******* QQ：14885553 ******
'*********************************
Sub Opiona()
'On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
Path = ThisWorkbook.Path & "\数据"
FileArr = FileAllArr(Path, "*.xlsx", ThisWorkbook.Name, False)
Filename = ""
For I = 0 To UBound(FileArr)
If InStr(Filename, GetPathFromFileName(FileArr(I))) = 0 Then
Filename = Filename & GetPathFromFileName(FileArr(I)) & ";"
End If
Next
FileNameArr = Split(Mid(Filename, 1, Len(Filename) - 1), ";") '//不重复工作簿名称列表
DirArr = FileAllArr(Path, "*.xlsx", ThisWorkbook.Name, True)
For I = 0 To 0 'UBound(FileNameArr)
Set NwBook = Workbooks.Add '新建一个工作簿
For K = 0 To UBound(DirArr) '//加入工作表，用文件夹命名
NewName = Replace(Replace(DirArr(K), ThisWorkbook.Path & "\数据", ""), "", "")
NwBook.Worksheets.Add().Name = NewName
Set Sh = NwBook.Sheets(NewName)
Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & DirArr(K) & FileNameArr(I) & ".xlsx"
StrSQL = "SELECT * FROM [" & FileNameArr(I) & "$]"
CRR = GET_SQLCoon(StrSQL, Str_coon, True)
Sh.Range("A1").Resize(UBound(CRR, 1) + 1, UBound(CRR, 2) + 1) = CRR
Next K
NwBook.SaveAs ThisWorkbook.Path & "\需要得到的结果" & FileNameArr(I) & ".xlsx" '另存为指定目录的指定文件名
NwBook.Close (True) '关闭（保存）
Next I
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
End Sub

复制代码

112ppp · 发表于 2014-12-22 17:20

opiona 发表于 2014-12-11 10:00
自定义函数见附件:
不知道是否符合要求

好像不行哦，只汇总了一个表。

cqcbc · 发表于 2014-12-22 19:10

还有问题，合并了复.xlsx，其他的没合并。

opiona · 发表于 2014-12-25 08:44

For I = 0 To 0 'UBound(FileNameArr)
修改成：

For I = 0 To UBound(FileNameArr)

复制代码

112ppp · 发表于 2015-1-21 13:54

opiona 发表于 2014-12-25 08:44
For I = 0 To 0 'UBound(FileNameArr)
修改成：

感谢，成功了，是我要的结果。

112ppp · 发表于 2015-1-21 14:36

本帖最后由 112ppp 于 2015-1-21 14:41 编辑

opiona 发表于 2014-12-25 08:44
For I = 0 To 0 'UBound(FileNameArr)
修改成：

这段代码是什么意思？为什么我放新的文件夹到数据文件夹里，就汇总不了了呢，这一句就反黄色的了。提示需要调试。

opiona · 发表于 2015-1-29 08:56

具体要看附件

vince鑫15 · 发表于 2016-5-31 15:36

本帖最后由 vince鑫15 于 2016-5-31 15:39 编辑

opiona 老师：
你好我和楼主有差不多的要求，但是我运行您的程序时似乎无法执行（因为我对VBA不太了解，所以我就是下载下来后按照楼主的格式设置了一下文件夹。然后run ）不知道问题在哪里？麻烦您帮我看一下（我需要合并的工作簿有上百个）``

vince鑫15 · 发表于 2016-5-31 15:49

opiona 发表于 2015-1-29 08:56
具体要看附件

老师您好，求助~~具体看9楼

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

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