0

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

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

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

第 1 行 - 行 / 排序 / 子目录 / 部分 / 段落 / 页面 / 交付 / 操作 / 所有者 / DueDate / 状态 / DateComp

第 2 行 - 2 / b / Confrnc / 2 / 2.2.1 / 8 / 出席 / 出席 / 约翰 / 13 年 5 月 23 日 / 未开始 /（空白）

每个工作簿都有一个与此完全相同的数据源表，其中包含多行数据。

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

行：

  1. 子猫；
  2. 行动;
  3. 所有者;
  4. 地位

列：

  1. 截止日期

价值观：

  1. 行动计数

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

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 的新手，但不是数据透视表。我试图避免必须手动将源工作簿中的所有数据编译到主工作簿中并从那里运行数据透视表，因为工作簿由三个不同的用户拥有并定期更新。我正在使用 OFFSET 公式来命名我的源数据范围，并将其用作我的数据透视表的数据源，因此它们都会立即更新，并且该公式会自动增加范围以包括已添加到的任何新行或列源数据表。

我也认识到，仅仅因为它可以工作到分组点，这并不意味着 PivotFields 的变量也正确完成 - 所以如果有人也看到那里的东西 - 我愿意听到它！

我在 Excel 2013 和 2010 中工作。

4

1 回答 1

0

从问题转移似乎是答案或尽可能接近的答案：

以下是我的数据集的屏幕截图，这些数据集显示了从每个单独的工作簿的数据集派生的数据透视表的外观，以及我希望通过运行脚本使其看起来如何：

http://i.stack.imgur.com/J6env.png

http://i.stack.imgur.com/joA34.png

看着@KazJaw 评论，我研究Range.Group并查看了该Periods部分。我最终完全删除了它并毫无问题地运行了脚本！必须手动调整字段列表和格式，但与提取实际数据相比，这是容易的部分，因为它总是不断变化。

于 2014-12-20T01:41:22.120 回答