合并多个工作簿的多个数据透视表以创建主数据透视表

我找到了一个代码，我（大部分）成功修改了我的使用，但是在分组功能上出错了 . 我有一个文件夹（目前）有三个工作簿 . 每个工作簿的格式完全相同，从工作表名称到每个工作表中的字段 . 每个工作簿都有两个从相同的唯一数据源派生的数据透视表（工作簿中的第三个工作表） .

我需要能够在新工作簿中运行一个脚本，允许我从公共文件夹中选择要合并到一个主数据透视表中的工作簿 . 我的源数据如下所示：

（在每列的名称之后和第2行中的数据之后使用的斜杠仅用于区分不同的列（总共12列，A到L包括在内））

第1行 - Line / Sort / Sub-Cat / Part / Para / Page / Deliv / Action / Owner / DueDate / Status / DateComp

第2 - 2 / b / Confrnc / 2 / 2.2.1 / 8 /参加/出席/ John / 23-May-13 / NotStarted /（空白）

每个工作簿都有一个与此类似的数据源表，包含多行数据 .

每个工作簿都有一个数据透视表，可以编译：

行：

• Sub-Cat;

• 行动;

• 所有者;

• 状态

专栏：

• DueDate

VALUES：

• 行动计数

我有以下代码我已经修改以满足我的需要复制并粘贴到新工作簿中的新模块（保存在与我的源工作簿相同的文件夹中）：

Option Explicit


Declare Function SetCurrentDirectoryA Lib "kernel32" (ByVal Path As String) As Long

'---------------------------------------------------------------------------------------
' Author: Rob Bovey
'---------------------------------------------------------------------------------------
Sub ChDirNet(Path As String)
    Dim Result As Long
    Result = SetCurrentDirectoryA(Path)
    If Result = 0 Then Err.Raise vbObjectError + 1, "Error changing to new path."
End Sub

'---------------------------------------------------------------------------------------
' Procedure : MergeFiles
' Author    : KL
' Date      : 22/08/2010
' Purpose   : Demonstration (http://www.planetaexcel.ru/forum.php?thread_id=18518)
' Comments  : Special thanks to
'             Debra Dalgleish for helping to fix ODBC driver issue
'             Hector Miguel Orozco Diaz for the "DeleteConnections_12" idea
'---------------------------------------------------------------------------------------
'
Sub MergeFiles()
    Dim PT As PivotTable
    Dim PC As PivotCache
    Dim arrFiles As Variant
    Dim strSheet As String
    Dim strPath As String
    Dim strSQL As String
    Dim strCon As String
    Dim rng As Range
    Dim i As Long

    strPath = CurDir
    ChDirNet ThisWorkbook.Path

    arrFiles = Application.GetOpenFilename("Excel Workbooks (*.xlsx), *.xlsx", , , , True)
    strSheet = "Deliverables"

    If Not IsArray(arrFiles) Then Exit Sub

    Application.ScreenUpdating = False

    If Val(Application.Version) > 11 Then DeleteConnections_12

    Set rng = ThisWorkbook.Sheets(1).Cells
    rng.Clear
    For i = 1 To UBound(arrFiles)
        If strSQL = "" Then
            strSQL = "SELECT * FROM [" & strSheet & "$]"
        Else
            strSQL = strSQL & " UNION ALL SELECT * FROM `" & arrFiles(i) & "`.[" & strSheet & "$]"
        End If
    Next i
    strCon = _
        "ODBC;" & _
        "DSN=Excel Files;" & _
        "DBQ=" & arrFiles(1) & ";" & _
        "DefaultDir=" & "" & ";" & _
        "DriverId=790;" & _
        "MaxBufferSize=2048;" & _
        "PageTimeout=5"

    Set PC = ThisWorkbook.PivotCaches.Add(SourceType:=xlExternal)

    With PC
        .Connection = strCon
        .CommandType = xlCmdSql
        .CommandText = strSQL
        Set PT = .CreatePivotTable(TableDestination:=rng(6, 1))
    End With

    With PT
        With .PivotFields(1)                             'Sub Category
            .Orientation = xlRowField
            .Position = 1
        End With
        .AddDataField .PivotFields(8), "DueDate", xlCount 'Action Required
        With .PivotFields(1)                             'Action Required
            .Orientation = xlRowField
            .Position = 1
        End With
        With .PivotFields(1)                             'Owner
            .Orientation = xlRowField
            .Position = 1
        End With
        With .PivotFields(2)                             'Status
            .Orientation = xlRowField
            .Position = 1
        .DataRange.Cells(1).Group _
                Start:=True, _
                End:=True, _
                Periods:=Array(False, False, False, False, True, False, False)
        End With
    End With

    'Clean up
    Set PT = Nothing
    Set PC = Nothing

    ChDirNet strPath
    Application.ScreenUpdating = True
End Sub

Private Sub DeleteConnections_12()
    '   This line won't work and wouldn't be necessary
    '   in the versions older than 2007
    '*****************************************************************************
    On Error Resume Next: ThisWorkbook.Connections(1).Delete: On Error GoTo 0
    '*****************************************************************************
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

当我运行脚本时，我到达第92行，在那里我得到一个运行时错误1004：无法对该选择进行分组 .

.DataRange.Cells(1).Group _
                Start:=True, _
                End:=True, _
                Periods:=Array(False, False, False, False, True, False, False)

对于我的生活，我迷路了，找不到任何可以解决这个问题的事情 .

有人可以提出任何建议或建议吗？

我在VBA仍然很新，但不是PivotTables . 我试图避免必须手动将源工作簿中的所有数据编译成主数据并从那里运行数据透视表，因为工作簿由三个不同的用户拥有并定期更新 . 我正在使用OFFSET公式来命名我的源数据范围，并将其用作我的数据透视表的数据源，以便它们一次更新，并且公式自动增加范围以包括已添加到的数据源中的任何新行或列 . 源数据表 .

我也认识到，仅仅因为它适用于分组点，这并不意味着数据透视表的变量也正确完成 - 所以如果有人也看到了某些东西 - 我很乐意听到它！

我在Excel 2013和2010中工作 .