VBA创建多个数据源的数据透视表

1、需求：

有多个表数据，格式一致，需要创建到1个数据透视表。

2、举例：

比如要分析工资的数据，工资表是按月分了不同Sheet管理的，现在需要把12个月的数据放到一起创建1个数据透视表。

3、代码实现

用过Excel的应该都用过透视表功能，透视表功能非常强大，而且简单易用，我们一般用透视表都是处理单独1个Sheet的数据，如果要完成多个Sheet的透视处理，可能大家想到的最直接的方法是复制到1个表里再处理，但是这样一旦数据源有变化，又要重新复制。

我们要完成这个功能，比较好的方法是用SQL语句将多个表拼接到一起再用数据透视表。用SQL语句对数据源的格式要求比较严格，所以表格要比较规范，建议：

标题在第1行
每一列保证数据格式是一致的，不要又有数字又有文本

如果你会SQL语句的话，不需要VBA也可以完成这个任务，例子需要的SQL语句是：

Select *,'1月' as 月份 from [1月$]
 Union All 
Select *,'2月' as 月份 from [2月$]
 Union All 
Select *,'3月' as 月份 from [3月$]

'x月' as 月份目的是为了在透视表里看出数据是属于哪一个Sheet的。

不用VBA的操作演示：

使用VBA代码自动创建，这种能更加方便的增加Sheet：

Sub vba_main()
    Dim str_sql As String
    
    str_sql = GetSql()
    
    Worksheets("透视表").Activate
    Cells.Clear
    CreatePivotCache str_sql, Range("A4")
End Sub

Function GetSql() As String
    Dim arr() As String
    
    ReDim arr(Worksheets.Count - 1 - 1) As String
    
    Dim i As Long
    For i = 1 To Worksheets.Count - 1
        arr(i - 1) = "Select *,'" & Worksheets(i).Name & "' as 月份 from [" & Worksheets(i).Name & "$]"
    Next
    
    GetSql = VBA.Join(arr, vbNewLine & " Union All " & vbNewLine)
End Function

'str_sql        sql语句
'rng            透视表的位置
Function CreatePivotCache(str_sql As String, rng As Range) As Long
    Dim AdoConn As Object, rst As Object
    
    Set AdoConn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    
    AdoConn.Open ProviderStr(rng.Parent.Parent.FullName)
    rst.Open str_sql, AdoConn
    
    With rng.Parent.Parent.PivotCaches.Add(xlExternal)
        Set .Recordset = rst
        .CreatePivotTable rng
    End With
    
    
    rst.Close
    AdoConn.Close
    Set rst = Nothing
    Set AdoConn = Nothing
End Function

Function ProviderStr(fileName As String) As String
    If Val(Application.Version) > 11 Then
        ProviderStr = "Provider =Microsoft.ACE.OLEDB.12.0;Data Source=" _
                    & fileName & ";Extended Properties=""Excel 12.0;HDR=YES"";"
    Else
        ProviderStr = "OLEDB;Provider =Microsoft.Jet.OLEDB.4.0;Data Source=" _
                    & fileName & ";Extended Properties=""Excel 8.0;HDR=YES"";"
    End If
End Function