excel如何合并多个工作薄的指定工作表

海誓山盟HOT · 发表于 2014-11-24 21:15

想用excel VBA的代码合并多个工作簿中的指定工作表，文件夹“合并5-6”存储路径在D盘下，文件夹里包含两个子文件夹，
每一个子文件夹对应一个excel工作薄，每个工作薄包含4个sheet，请教高手如何用VBA的方法打开每个子文件夹下的excel并合并对应的相同名字的工作表到新建的工作薄中（最好能注明下每条代码的含义），非常感谢哈！详情请见附件

合并5-6.rar (16.46 KB, 下载次数: 3)

opiona · 发表于 2014-11-25 14:07

附件：

合并5-6.rar (40.3 KB, 下载次数: 358)

'*********************************
'******* 北极狐工作室出品 ******
'******* QQ：14885553 ******
'*********************************
Sub Opiona() '//函数实例
'On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
t = Timer '//开始时间
Set SH0 = Worksheets("首页")
For Each SH In ThisWorkbook.Sheets '//删除汇总表的其他表格
If SH.Name <> SH0.Name Then
SH.Delete
End If
Next SH
ARR = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name, False)
For k = 2 To SH0.Range("A65536").End(3).Row '//循环需要的工作表
If SH0.Cells(k, 1) <> "" Then '//非空就执行
ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)).Name = SH0.Cells(k, 1) '//建立新表
Set SH = ThisWorkbook.Worksheets(SH0.Cells(k, 1).Value)
Set WB = Workbooks.Open(ARR(0)) '//打开找到的第一个文件
Set SH1 = WB.Worksheets(SH0.Cells(k, 1).Value)
SH1.Cells.Copy SH.Range("A1") '//复制表过来，含标题和数据
SH.Range("A" & SH0.Cells(k, 2) & ":AZ65536").ClearContents '//删除其中的数据,保留标题行
WB.Close False '//关闭文件
Rem 上面建立一个新表，病好了标题行
For I = 0 To UBound(ARR) '//循环所有找到的文件
Str_coon = "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO;';data source=" & ARR(I) '//OFFICE2003
StrSQL = "SELECT * FROM [" & SH.Name & "$A" & SH0.Cells(k, 2) & ":AZ65536]" '//查询标题行下面的数据
IROW = SH.Range("a65536").End(3).Row + 1 '//不是第一个则在A列第一个空白行开始粘贴
If IROW < 3 Then IROW = SH0.Cells(k, 2) '//第一个按照数据行粘贴找到的数据，
CRR = GET_SQLCoon(StrSQL, Str_coon, False) '//执行查询
SH.Range("A" & IROW).Resize(UBound(CRR, 1) + 1, UBound(CRR, 2) + 1) = CRR '//粘贴查询结果
Next I
End If
Next k
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!" '//提示所用时间
End Sub
Rem 下面是需要用到的自定义函数
'*****************************************************************************************
'函数名： GET_SQLCoon
'函数功能：获得指定SQL的查询结果，自定义连接字符串，可以连接各种数据库
'返回值：返回一个二维数组
'参数1： StrSQL 字符类型 SQL查询语句
'参数2： Str_coon 字符类型数据库连接语句
'参数3： Biaoti 可参数选是否输出标题，默认带有标题
'使用方法： Arr = GET_SQLCoon(StrSQL,Str_coon,true)
' Arr(0,1) '//数组第一行为标题行，从i=1 开始是数据
' Sh2.Range("A2").Resize(UBound(ARR, 1) + 1, UBound(ARR, 2) + 1) = ARR
'*****************************************************************************************
Public Function GET_SQLCoon(ByVal StrSQL As String, ByVal Str_coon As String, Optional Biaoti As Boolean = True) As Variant()
On Error Resume Next ' 改变错误处理的方式。
Dim Cn, RS
Err.Clear
Set Cn = CreateObject("Adodb.Connection") '//新建一个ADO连接
Set RS = CreateObject("adodb.recordset")
Cn.Open Str_coon
RS.Open StrSQL, Cn, 1, 3
If RS.RecordCount > 0 Then '//如果找到数据
If Biaoti = True Then
ReDim ARR(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
For a = 0 To RS.Fields.Count - 1 '//导入标题
ARR(0, a) = RS.Fields(a).Name
Next
For I = 0 To RS.RecordCount - 1 '//导入数据
For a = 0 To RS.Fields.Count - 1
ARR(I + 1, a) = RS.Fields(a).Value
Next a
RS.MoveNext
Next
Else
ReDim ARR(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
For I = 0 To RS.RecordCount - 1 '//导入数据
For a = 0 To RS.Fields.Count - 1
ARR(I, a) = RS.Fields(a).Value
Next a
RS.MoveNext
Next
End If
Else '//如果没有找到数据
ReDim ARR(1, 1)
ARR(0, 0) = ""
End If
GET_SQLCoon = ARR
Cn.Close '//关闭ADO连接
Set RS = Nothing
Set Cn = Nothing '//释放内存
End Function
'*******************************************************************************************************
'功能：查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）
'函数名： FileAllArr
'参数1： Filename 需查找的文件夹名不含最后的""
'参数2： FileFilter 需要过滤的文件名，可省略，默认为：[*.*]
'参数3： Liwai 剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
'参数4： Files 是否只要文件夹名，可省略，默认为：FALSE
'返回值：一个字符型的数组
'使用方法：arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name,false)
'作者: 北极狐工作室 QQ：14885553
'*******************************************************************************************************
Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "", Optional ByVal Files As Boolean = False) As String()
Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象
Set Did = CreateObject("Scripting.Dictionary")
Dic.Add (Filename & ""), ""
I = 0
Do While I < Dic.Count
Ke = Dic.keys '开始遍历字典
MyName = Dir(Ke(I), vbDirectory) '查找目录
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录
Dic.Add (Ke(I) & MyName & ""), "" '就往字典中添加这个次级目录名作为一个条目
End If
End If
MyName = Dir '继续遍历寻找
Loop
I = I + 1
Loop
Dim arrx() As String
I = 0
If Files = True Then '//是否只输出文件夹名
For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
ReDim Preserve arrx(I)
If Ke <> Filename & "" Then '//自身文件夹除外
arrx(I) = Ke
I = I + 1
End If
Next
FileAllArr = arrx
Else
For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
Do While MyFileName <> ""
If MyFileName <> Liwai Then '排除例外文件
ReDim Preserve arrx(I)
arrx(I) = Ke & MyFileName
I = I + 1
End If
MyFileName = Dir
Loop
Next
FileAllArr = arrx
End If
End Function
'****************************************************************
'*'****************************************************************************************************
'函数: GetPathFromFileName 根据全路径获得文件名
'参数1：strFullPath 完整路径
'参数2：kzm true 返回字符串含扩展名
'参数3：strSplitor 各级文件夹分隔符
'作用: 从完整路径获取返回: 文件名(true带扩展名)
'使用方法: msgbox GetPathFromFileName("C:\windows\text.txt",true)
'作者: 北极狐工作室 QQ：14885553
'*'****************************************************************************************************
Public Function GetPathFromFileName(ByVal strFullPath As String, Optional ByVal kzm As Boolean = True, Optional ByVal strSplitor As String = "") As String
Dim FileName1 As String
Dim FNAME As String
FileName1 = Left$(strFullPath, InStrRev(strFullPath, strSplitor, , vbTextCompare))
FileName1 = Replace(strFullPath, FileName1, "")
If kzm = False Then
GetPathFromFileName = Left(FileName1, InStr(FileName1, ".") - 1)
Else
GetPathFromFileName = FileName1
End If
End Function
'*'****************************************************************************************************

复制代码

海誓山盟HOT · 发表于 2014-11-25 15:31

opiona 发表于 2014-11-25 14:07
附件：

好的太感谢您了！相当详细呀~刚开始接触这个有一些基础的东西不太懂啊，如果我的合并5-6文件夹存储路径在D盘下text文件夹内，要如何修改代码呢？D:\text\合并5-6 谢谢啦！

opiona · 发表于 2014-11-25 15:40

本帖最后由 opiona 于 2014-11-25 15:42 编辑

20.ARR = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name, False)

这个换成：20.ARR = FileAllArr(D:\text\合并5-6 , "*.xls", ThisWorkbook.Name, False)

或者将汇总这个表放到这个文件夹内即可

海誓山盟HOT · 发表于 2014-11-26 11:58

opiona 发表于 2014-11-25 15:40
20.ARR = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name, False)

这个换成：20.ARR = File ...

刚才试了一下，下标越界是怎么回事呢？

海誓山盟HOT · 发表于 2014-11-26 13:16

opiona 发表于 2014-11-25 15:40
20.ARR = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name, False)

这个换成：20.ARR = File ...

39. SH.Range("A" & IROW).Resize(UBound(CRR, 1) + 1, UBound(CRR, 2) + 1) = CRR '//粘贴查询结果这行是报错调试语句（下标越界 9），汇总表只能合并所有文件夹下的附件1 sheet,不能合并所有文件夹下的附件2-附件4的内容，您帮我看看是怎么回事？

海誓山盟HOT · 发表于 2014-11-26 22:28

opiona 发表于 2014-11-25 15:40
20.ARR = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name, False)

这个换成：20.ARR = File ...

39. SH.Range("A" & IROW).Resize(UBound(CRR, 1) + 1, UBound(CRR, 2) + 1) = CRR '//粘贴查询结果这行是报错调试语句（下标越界 9），汇总表只能合并所有文件夹下的附件1 sheet,不能合并所有文件夹下的附件2-附件4sheet的内容，您帮我看看是怎么回事？能加您下QQ嘛？以后有什么问题还得继续请教您！

jjmysjg · 发表于 2014-11-27 10:54

先留存，下载

janemark · 发表于 2016-11-14 09:31

opiona 发表于 2014-11-25 14:07
附件：

我有一个合并工作的问题，请看一下。合并

LMY123 · 发表于 2018-4-6 10:06

合并同名工作表，含各级子文件夹中的

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

[求助] excel如何合并多个工作薄的指定工作表

评分