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 sql As String
Dim oFileName As String
Dim arr() As Variant
Dim brr() As Variant
Dim sqlstr As String
Dim str2 As String
Dim dic As Object
Dim Conn As New ADODB.Connection
oFileName = Dir(ThisWorkbook.Path & "\*.xls")
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary") '創(chuàng)建字典
'刪除先前的所有數(shù)據(jù)透視表，目的在編輯代碼時(shí)易于調(diào)試！
For Each pt In Sheet1.PivotTables
pt.TableRange2.Clear '在沒有頁字段時(shí)可采用TableRange1.Clear方法來清除透視表 _
。pt.TableRange2表示全選透視表單元格！
Next pt
'設(shè)置透視表的緩存，采用PivotCaches.Add方法，確定數(shù)據(jù)源的類型為引用外部數(shù)據(jù)源！
Set pc = ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
With pc
'使用connection確定外部數(shù)據(jù)源的連接方式為ODBC， _
文件類型為excel文件，確定數(shù)據(jù)源的位置和默認(rèn)文件夾的位置！
.Connection = Array("ODBC;DSN=excel files;DBQ=" & ThisWorkbook.FullName & ";DefaultDir=" & ThisWorkbook.Path)
.CommandType = xlCmdSql '返回命令類型！本例為返回excel的SQL命令。
sql = "SELECT @ FROM `" & ThisWorkbook.Path & "\"
Do While oFileName <> ""
If oFileName <> ThisWorkbook.Name Then
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " _
& " extended properties=excel 8.0;" _
& " Data Source=" & ThisWorkbook.Path & "\" & oFileName
Dim Cat As New ADOX.Catalog '引用ADOX 操作庫,表,字段 等對(duì)象
Set Cat.ActiveConnection = Conn
Dim cTab As ADOX.Table '定義表
Dim fld As ADOX.Column '定義字段
For Each cTab In Cat.Tables '循環(huán)庫中每個(gè)表
str = ""
For Each fld In cTab.Columns '循環(huán)表中每個(gè)字段
If fld <> "F1" Then '如果為空表,則字段名為"F1",實(shí)用表不會(huì)以"F1"為字段
'去掉部門名稱,科目代碼兩個(gè)固定字段外判斷字段是否存在,不存在則執(zhí)行加入字典
If Not dic.exists(fld.Name) And fld.Name <> "部門名稱" And fld.Name <> "科目代碼" Then
dic(fld.Name) = ""
sqlstr = sqlstr & " " & fld.Name '用 sqlstr 記住即將在 SQL語句中用到的SELECT中的字段,且不重復(fù)用的" "連接成字符串
End If
str = str & " " & fld.Name ' 記錄不同表中的字段,用" "連接成字符串,這里包括 部門名稱,科目代碼,和 sqlstr 不同的
'本來應(yīng)該在 循環(huán)庫中每個(gè)表 時(shí)加入字典的,但因?yàn)樵?循環(huán)庫中每個(gè)表時(shí)不能判斷表是否為空, _
所以只能在 表中循環(huán)每個(gè)字段時(shí)判斷,如果為"F1"則過濾,這樣就可把空表忽略過去
If Not dic.exists(oFileName & cTab.Name & "表") Then
i = i + 1
dic(oFileName & cTab.Name & "表") = i '加入字典,并計(jì)算數(shù)量(實(shí)際就是每個(gè)非空表的并表明是出自于哪個(gè)工作簿)
ReDim Preserve arr(1 To i) '定義一個(gè)數(shù)組,與上面符合表的數(shù)量相等
arr(i) = sql & Left(oFileName, Len(oFileName) - 4) & "`.`" & cTab.Name & "`" '逐一加入arr數(shù)組sql語句
If Not dic.exists(oFileName & "工作簿") Then '這里加"工作簿"和"表"一樣的沒有多大意義,僅僅是區(qū)分, _
本來應(yīng)用兩個(gè)字典以上,現(xiàn)在用一個(gè)怕混淆,所以加些詞以區(qū)分而已
j = j + 1
dic(oFileName & "工作簿") = ""
If j > 1 Then arr(i) = "] " & arr(i) '這里用"] "實(shí)際就是把每個(gè)不同工作簿用"] "隔開,可按 F8 查看, _
為的是在以后SQL語句中 用" / UNION ALL " 替換" UNION ALL ] "
End If
End If
End If
Next
ReDim Preserve brr(1 To i) '在上面相應(yīng)的產(chǎn)生arr(i)的同時(shí)也產(chǎn)生brr(i)
If str <> "" Then brr(i) = str ' 如果沒有 If str <> "" Then , 那么brr(i)將不會(huì)忽略空表,而arr(i)是 _
忽略空表的,最后 每個(gè) brr(i) 不會(huì)對(duì)應(yīng) 每個(gè)arr(i),所以這里 請(qǐng)用 F8 逐條運(yùn)行'
'由 If str <> "" Then 保證 每個(gè) brr(i) 也是有效的并可對(duì)應(yīng) arr(i), _
另外每個(gè) brr(i) 就是 每個(gè)表的 所有字段 ,查看上面的 str 是如何得來的
Next
Conn.Close
End If
oFileName = Dir()
Loop
For k = 1 To i ' i 等于 每個(gè)工作簿每個(gè)有數(shù)值的工作表的總和,全面我們已經(jīng)做了
str2 = ""
For j = 0 To UBound(Split(sqlstr, " ")) ' 用 Split 函數(shù) 把 在字符串中用" "聯(lián)合的每個(gè)字段再用 " " 分離出來
If InStr(brr(k), Split(sqlstr, " ")(j)) Then '查找每個(gè)brr(k)數(shù)組(即每個(gè)表)中是否含有某些字段
If str2 <> "" Then str2 = str2 & "," ' 如果找到,并且不為第一個(gè)則 用"," 號(hào)連接,大家想一下select語 _
句中的每個(gè)字段是否用"," 號(hào)隔開
str2 = str2 & Split(sqlstr, " ")(j) '大家可以測(cè)試 用這種方法測(cè)試普通字符串連接操作,","號(hào)不會(huì)在兩邊
Else
If str2 <> "" Then str2 = str2 & ","
str2 = str2 & " 0 as " & Split(sqlstr, " ")(j) '如果沒找到,按照SQL語句以及數(shù)據(jù)透視表如果數(shù)據(jù)為空則默認(rèn)為計(jì)數(shù) _
匯總,如果為0則會(huì)默認(rèn)為數(shù)量匯總,所以為 " 0 as 字段1 " 的形式
End If
'每個(gè) brr(k) 就是最上面 每個(gè) brr(i) ,就是 k 就是最上面的 i
Next
arr(k) = Replace(arr(k), "@", " 部門名稱,科目代碼," & str2) '每個(gè)arr(k) 就是最上面的 每個(gè) arr(i),把 每個(gè)arr(k)中的 sql字符( SELECT @ FROM )中 _
的 [@] 替換成 [部門名稱,科目代碼," & str2],str2我們知道是什么了吧,前面已求, _
這樣整個(gè)SQL語句就比較完整了
Next
str = Replace(Join(arr, " / UNION ALL "), " UNION ALL ] ", " / UNION ALL ") '用 JOIN 函數(shù) 把a(bǔ)rr數(shù)組中各元素 用" / UNION ALL " 連接, _
以前在每個(gè)工作簿間都有 "] "隔開,就形成 _
<< select ......from ... / UNION ALL select ......from .../ UNION ALL ] select ......from ...>>
'從上面的sql語句可以看出一個(gè)工作簿的每個(gè)工作表只用 " / UNION ALL " 連接 ,而不同工作簿的(即上一個(gè)工作 _
簿的最后一個(gè)工作表 和 下一個(gè)工作簿的 第一工作表 之間 是用 " / UNION ALL ] " 連接 ,是不一樣的 . _
這樣的話 ,再用 " / UNION ALL " 替換 " UNION ALL ] " ,這樣一個(gè)完整的 SQL語句就完成了,形成 _
<< select ......from ... / UNION ALL select ......from ...// UNION ALL select ......from ...>>
.CommandText = Split(str, "/") '如果在用Split函數(shù) 再加上 "/"字符分離撥開,那么表與表之間工作簿與工作簿之間完全符合 數(shù)據(jù)透視表的要求了,哈哈!
End With
Set pt = pc.CreatePivotTable(tabledestination:=Sheet1.Cells(4, 1), tablename:="pt1")
pt.ManualUpdate = True '停止透視表的計(jì)算，為快速向透視表添加字段做準(zhǔn)備！
'使用AddFields方法為數(shù)據(jù)表添加行，列和頁字段，本例中“Data” _
為虛擬的數(shù)據(jù)字段，表示數(shù)據(jù)字段放置在透視表的列區(qū)域！
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 '透視表添加完字段后，重新計(jì)算數(shù)據(jù)透視表，以顯示正確結(jié)果。
pt.ManualUpdate = True
Application.ScreenUpdating = True
Set pt = Nothing '釋放變量占用的內(nèi)存！
Set pc = Nothing
End Sub
