|
透视表汇总多工作簿数据!(令人惊叹的功能!)--第二部
不过其中两个列头是有规律的 : "部门名称" ,"科目代码"
1,不等表(每个工作簿中工作表数量不等,名称没有规律)
2,不等列(每个工作簿中工作表每 列 的数量,名称(字段)不等)
3,可以有空表,将忽略过去。
Option Explicit
Sub 多工作表透视汇总()
Dim ws As Worksheet
Dim pc As PivotCache
Dim pt As PivotTable
Dim str As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim s As String
Dim f As String
Dim arr() As Variant
Dim brr() As Variant
Dim sqlstr As String
Dim str2 As String
Dim d As Object
Dim Conn As New ADODB.Connection
f = Dir(ThisWorkbook.Path & "\*.xls")
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary") '删除先前的所有数据透视表,目的在编辑代码时易于调试!
For Each pt In Sheet1.PivotTables
pt.TableRange2.Clear '在没有页字段时可采用TableRange1.Clear方法来清除透视表 _
。pt.TableRange2表示全选透视表单元格!
Next pt
'设置透视表的缓存,采用PivotCaches.Add方法,确定数据源的类型为引用外部数据源!
Set pc = ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
With pc
'使用connection确定外部数据源的连接方式为ODBC, _
文件类型为excel文件,确定数据源的位置和默认文件夹的位置!
.Connection = Array("ODBC;DSN=excel files;DBQ=" & str & ";DefaultDir=" & ThisWorkbook.Path)
.CommandType = xlCmdSql '返回命令类型!本例为返回excel的SQL命令。
s = "SELECT @ FROM `" & ThisWorkbook.Path & "\"
Do While f <> ""
If f <> ThisWorkbook.Name Then
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " _
& " extended properties=excel 8.0;" _
& " Data Source=" & ThisWorkbook.Path & "\" & f
Dim Cat As New ADOX.Catalog
Set Cat.ActiveConnection = Conn
Dim cTab As ADOX.Table
Dim fld As ADOX.Column
For Each cTab In Cat.Tables
str = ""
For Each fld In cTab.Columns
If fld <> "F1" Then
If Not d.exists(fld.Name) And fld.Name <> "部门名称" And fld.Name <> "科目代码" Then
k = k + 1
d(fld.Name) = k
sqlstr = sqlstr & " " & fld.Name
End If
str = str & " " & fld.Name
If Not d.exists(f & cTab.Name & "表") Then
i = i + 1
d(f & cTab.Name & "表") = i
ReDim Preserve arr(1 To i)
arr(i) = s & Left(f, Len(f) - 4) & "`.`" & cTab.Name & "`"
If Not d.exists(f & "工作簿") Then
j = j + 1
d(f & "工作簿") = ""
If j > 1 Then arr(i) = "] " & arr(i)
End If
End If
End If
Next
ReDim Preserve brr(1 To i)
If str <> "" Then brr(i) = str
Next
Conn.Close
End If
f = Dir()
Loop
For k = 1 To i
str2 = ""
For j = 0 To UBound(Split(sqlstr, " "))
If InStr(brr(k), Split(sqlstr, " ")(j)) Then
If str2 <> "" Then str2 = str2 & ","
str2 = str2 & Split(sqlstr, " ")(j)
Else
If str2 <> "" Then str2 = str2 & ","
str2 = str2 & " 0 as " & Split(sqlstr, " ")(j)
End If
Next
arr(k) = Replace(arr(k), "@", " 部门名称,科目代码," & str2)
Next
str = Replace(Join(arr, " / UNION ALL "), "UNION ALL ]", " / UNION ALL ")
.CommandText = Split(str, "/")
End With
Set pt = pc.CreatePivotTable(tabledestination:=Sheet1.Cells(4, 1), tablename:="pt1")
pt.ManualUpdate = True '停止透视表的计算,为快速向透视表添加字段做准备!
'使用AddFields方法为数据表添加行,列和页字段,本例中“Data” _
为虚拟的数据字段,表示数据字段放置在透视表的列区域!
pt.AddFields RowFields:="部门名称", ColumnFields:="Data"
k = 0
For i = 1 To pt.PivotFields.Count
If pt.PivotFields(i) <> "部门名称" And pt.PivotFields(i) <> "科目代码" Then
k = k + 1
With pt.PivotFields(i)
.Orientation = xlDataField
.Position = k
.Name = " " & pt.PivotFields(i)
End With
End If
Next
pt.ManualUpdate = False '透视表添加完字段后,重新计算数据透视表,以显示正确结果。
pt.ManualUpdate = True
Application.ScreenUpdating = True
Set pt = Nothing '释放变量占用的内存!
Set pc = Nothing
Set ws = Nothing
End Sub
[ 本帖最后由 office2008 于 2009-4-22 19:41 编辑 ] |
评分
-
1
查看全部评分
-
|