Excel 透视表汇总多工作簿数据 Excel数据透视...

http://club.excelhome.net/thread-425500-2-1.html Option Explicit

Sub 多工作表透视汇总()
    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")                                        '创建字典
                                    '删除先前的所有数据透视表，目的在编辑代码时易于调试！
    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=" & 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 操作库,表,字段 等对象
                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                   '如果为空表,则字段名为"F1",实用表不会以"F1"为字段
                              '去掉部门名称,科目代码两个固定字段外判断字段是否存在,不存在则执行加入字典
                            If Not dic.exists(fld.Name) And fld.Name <> "部门名称" And fld.Name <> "科目代码" Then
                                dic(fld.Name) = ""
                                sqlstr = sqlstr & "  " & fld.Name  '用 sqlstr 记住即将在 SQL语句中用到的SELECT中的字段,且不重复用的"  "连接成字符串
                            End If
                            str = str & "  " & fld.Name  '    记录不同表中的字段,用"  "连接成字符串,这里包括 部门名称,科目代码,和 sqlstr 不同的
                           
                                                              
                            '本来应该在 循环库中每个表 时加入字典的,但因为在 循环库中每个表时不能判断表是否为空, _
                            所以只能在 表中循环每个字段时判断,如果为"F1"则过滤,这样就可把空表忽略过去
                           
                            If Not dic.exists(oFileName & cTab.Name & "表") Then
                                i = i + 1
                                dic(oFileName & cTab.Name & "表") = i    '加入字典,并计算数量(实际就是每个非空表的并表明是出自于哪个工作簿)
                                ReDim Preserve arr(1 To i)               '定义一个数组,与上面符合表的数量相等
                                arr(i) = sql & Left(oFileName, Len(oFileName) - 4) & "`.`" & cTab.Name & "`"  '逐一加入arr数组sql语句
                                If Not dic.exists(oFileName & "工作簿") Then   '这里加"工作簿"和"表"一样的没有多大意义,仅仅是区分, _
                                                                                本来应用两个字典以上,现在用一个怕混淆,所以加些词以区分而已
                                    j = j + 1
                                    dic(oFileName & "工作簿") = ""
                                    If j > 1 Then arr(i) = "] " & arr(i)     '这里用"] "实际就是把每个不同工作簿用"] "隔开,可按 F8 查看, _
                                                                             为的是在以后SQL语句中 用" / UNION ALL " 替换" UNION ALL ] "
                                End If
                            End If
                        End If
                    Next
                    ReDim Preserve brr(1 To i)                  '在上面相应的产生arr(i)的同时也产生brr(i)
                    If str <> "" Then brr(i) = str             ' 如果没有 If str <> "" Then , 那么brr(i)将不会忽略空表,而arr(i)是 _
                                                               忽略空表的,最后 每个 brr(i) 不会对应 每个arr(i),所以这里 请用 F8 逐条运行'
                                                               '由 If str <> "" Then 保证 每个 brr(i) 也是有效的并可对应 arr(i), _
                                                                另外每个 brr(i) 就是 每个表的 所有字段 ,查看上面的 str 是如何得来的
                Next
                Conn.Close
            End If
            oFileName = Dir()
        Loop
        For k = 1 To i                           ' i 等于 每个工作簿每个有数值的工作表的总和,全面我们已经做了
            str2 = ""
            For j = 0 To UBound(Split(sqlstr, "  "))  ' 用 Split 函数 把 在字符串中用"  "联合的每个字段再用 "  " 分离出来
                If InStr(brr(k), Split(sqlstr, "  ")(j)) Then   '查找每个brr(k)数组(即每个表)中是否含有某些字段
                    If str2 <> "" Then str2 = str2 & ","         ' 如果找到,并且不为第一个则 用"," 号连接,大家想一下select语 _
                                                                   句中的每个字段是否用"," 号隔开
                    str2 = str2 & Split(sqlstr, "  ")(j)           '大家可以测试 用这种方法测试普通字符串连接操作,","号不会在两边
                Else
                    If str2 <> "" Then str2 = str2 & ","
                    str2 = str2 & " 0 as " & Split(sqlstr, "  ")(j)   '如果没找到,按照SQL语句以及数据透视表如果数据为空则默认为计数 _
                                                                      汇总,如果为0则会默认为数量汇总,所以为 " 0 as 字段1 " 的形式
                End If
                                                          '每个 brr(k) 就是最上面 每个 brr(i) ,就是 k 就是最上面的 i
            Next
            arr(k) = Replace(arr(k), "@", " 部门名称,科目代码," & str2)   '每个arr(k) 就是最上面的 每个 arr(i),把 每个arr(k)中的 sql字符( SELECT @ FROM )中 _
                                                                           的 [@]  替换成 [部门名称,科目代码," & str2],str2我们知道是什么了吧,前面已求, _
                                                                           这样整个SQL语句就比较完整了
        Next
        str = Replace(Join(arr, "  / UNION ALL "), " UNION ALL ] ", " / UNION ALL ")  '用 JOIN 函数 把arr数组中各元素 用"  / UNION ALL " 连接, _
                                                                                   以前在每个工作簿间都有 "] "隔开,就形成 _
                                                                                   << select ......from ... / UNION ALL  select ......from .../ UNION ALL ] select ......from ...>>
                                                                                    '从上面的sql语句可以看出一个工作簿的每个工作表只用 " / UNION ALL " 连接 ,而不同工作簿的(即上一个工作 _
                                                                                    簿的最后一个工作表 和 下一个工作簿的 第一工作表 之间 是用 " / UNION ALL ] " 连接 ,是不一样的 . _
                                                                                    这样的话 ,再用 " / UNION ALL " 替换 " UNION ALL ] " ,这样一个完整的 SQL语句就完成了,形成 _
                                                                                    << select ......from ... / UNION ALL  select ......from ...// UNION ALL  select ......from ...>>
        .CommandText = Split(str, "/")                                             '如果在用Split函数 再加上 "/"字符分离拨开,那么表与表之间工作簿与工作簿之间完全符合 数据透视表的要求了,哈哈!

    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

End Sub