[分享]汇总文件夹内所有工作簿的所有工作表记录

gvntw

单击一下按钮，轻松汇总文件夹内所有Excel文件（*.xls）的所有工作表记录。

Code:

Private Sub CommandButton1_Click()
Dim d As New Dictionary, arr(), i%, j%
Dim cn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim cat As New Catalog
Dim sql$, MyPath$, MyFiles$, TWb$

On Error GoTo Err
Cells = Empty '清空单元格数据
TWb = ThisWorkbook.Name

MyPath = ThisWorkbook.Path
MyFiles = Dir(MyPath & "*.xls")
Do While MyFiles <> ""
If TWb <> MyFiles Then
d.Add MyFiles, 0
j = j + 1
End If
MyFiles = Dir
Loop

If j = 0 Then
MsgBox "没有文件可合并", , "gvntw"
Exit Sub
End If

arr = d.Keys: d.RemoveAll

For i = 0 To UBound(arr)
cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & "" & arr(i)
Set cat.ActiveConnection = cn
For Each Tabs In cat.Tables
sql = "Select """ & Replace(arr(i), ".xls", "") & """ as 单位,""" & Replace(Tabs.Name, "$", "") & """ as 月份,* From [Excel 8.0;DATABASE=" & MyPath & "" & arr(i) & "].[" & Tabs.Name & "]"
d.Add sql, 0
Next
cn.Close
Next

sql = Join(d.Keys, " UNION ALL ")
sql = "SELECT * from (" & sql & ") order by 姓名,月份"
cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & arr(0)
Set rst = cn.Execute(sql)

For i = 1 To rst.Fields.Count
Cells(1, i) = rst(i - 1).Name
Next

Range("a2").CopyFromRecordset rst
rst.Close: Set rst = Nothing
cn.Close: Set cn = Nothing: Set d = Nothing
MsgBox "表格已汇总完成", , "gvntw"
Exit Sub

Err:
MsgBox Err.Description, , "错误报告"
End Sub

2008-8/20088131174698803.zip

zxl_fm

楼主高手啊，能帮我添加你的这个功能在我的工作薄吗？2008-8/200881311492756074.rar

表格内容为每月1-31日业绩情况

需要实现的功能，将每天报表中的业绩记录完全复制到一张新的工作表。

谢谢！

gvntw

TO zxl_fm:

你的表格有点乱，我没看懂。

如果要汇总每个人的数据，可以把最后一句sql改一下：

sql = "SELECT 姓名,sum(保障工资) as 保障工资,sum(岗位工资) as 岗位工资,sum(津贴工资) as 津贴工资,sum(绩效工资) as 绩效工资,sum(应发工资) as 应发工资,sum(代扣保险个税年金) as 代扣项目,sum(实发工资) as 实发工资 from (" & sql & ") group by 姓名 order by 姓名"

[此贴子已经被作者于2008-8-14 12:52:39编辑过]

zxl_fm

gvntw 版主：

这样的，就是我的工作薄当中有一部分工作表名称是数字的，这是按当天日期作为工作表名称的。在这些工作表里面内容分为两部分，上面的一部分是业绩情况，下面的是各个银行帐户的资金情况。

现在我想把这些工作表里面的业绩全部按记录做到一张工作表里面。我看了你的汇总表格后觉得非常好，但是我看不懂你写的代码.所以把工作表发给你，你帮我看一下怎么样可以实现我的想法。谢谢

gvntw

插入一工作表用于汇总，并复制标题行

Rem 引用 Microsoft ActiveX Data Objects 2.8 Library
Sub gvntw()
Dim i As Long, j As Long, sh As Worksheet '声明Long和工作表变量
Dim sql As String, arr() '声明String和数组变量
Dim cn As New ADODB.Connection 'ADO对象变量

On Error GoTo Err '发生错误直接跳到Err
Application.ScreenUpdating = False '关闭屏幕刷新，提高代码运行速度
Rem 打开联接
cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & ThisWorkbook.FullName

For Each sh In ThisWorkbook.Worksheets '循环工作表
If IsNumeric(sh.Name) Then '如果工作表名为数字
i = sh.Range("A:A").Find("合计").Row - 1 '查找合计行
sql = "select * from [" & sh.Name & "$A5:S" & i & "]" 'sql语句
j = j + 1 '数组添加一个数据
ReDim Preserve arr(1 To j) '当改变数组最末维的大小，使用Preserve以保持数组中原来的数据。
arr(j) = sql '赋值给数组
End If '判断结束
Next '进入下一个迭代循环

[a4:s65536] = Empty '数据置空
sql = Join(arr, " union all ") '把数组用" union all "连接为字符串
Range("A4").CopyFromRecordset cn.Execute(sql) '放置查询结果
Rem 关闭并释放对象变量所占用的系统资源。当数据库查询结果非常大时，它占用了很多系统资源，所以在使用完之后，必须释放他的系统资源。
Erase arr: cn.Close: Set cn = Nothing
Application.ScreenUpdating = True '恢复屏幕刷新
MsgBox "数据已汇总完成", , "gvntw提示" '使用MsgBox函数提示数据汇总完成
Exit Sub '退出过程

Err:
MsgBox Err.Description, , "错误报告" '发生错误时的错误报告
End Sub

2008-8/200881611475331329.rar

zxl_fm

谢谢gvntw，大幅提高了工作效率啊

gvntw

sql语句可以更改如下，以去除空行。

sql = "select * from [" & sh.Name & "$A5:S" & i & "] where not isnull(F1)"