0

使用するために (ほとんど) 正常に変更されたコードを見つけましたが、グループ化関数でエラーが発生しています。(現在) 3 つのワークブックを含むフォルダーがあります。各ワークブックは、シート名から各シート内のフィールドまで、まったく同じようにフォーマットされています。各ワークブックには、同じ一意のデータ ソース (ワークブックの 3 番目のシート) から派生した 2 つのピボットテーブルがあります。

新しいワークブックで、1 つのマスター ピボット テーブルに結合する共通フォルダーからワークブックを選択できるようにするスクリプトを実行できる必要があります。ソース データは次のようになります。

(各列の名前の後ろと行 2 のデータの後に使用されるスラッシュは、異なる列を区別するためだけに使用されています (合計 12、A から L を含む))

行 1 - 行 / 並べ替え / サブカテゴリ / パーツ / パラ / ページ / 配送 / アクション / 所有者 / 期日 / ステータス / 日付コンプ

行 2 - 2 / b / Confrnc / 2 / 2.2.1 / 8 / 出席 / 出席 / ジョン / 2013 年 5 月 23 日 / NotStarted / (空白)

各ワークブックには、このように設定されたデータ ソース シートがあり、複数のデータ行があります。

各ワークブックには、以下をコンパイルするピボット テーブルがあります。

行:

  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: Cannot group that selection. が表示されます。

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

私の人生では、私は迷子になり、これを修正する場所がどこにも見つかりません。

誰でも推奨事項や提案を行うことができますか?

私はまだ VBA について非常に初心者ですが、ピボットテーブルについてはそうではありません。ワークブックは 3 人の異なるユーザーによって所有され、定期的に更新されるため、ソース ワークブックのすべてのデータを手動でマスターにコンパイルし、そこからピボットテーブルを実行する必要がないようにしています。OFFSET 数式を使用してソース データ範囲に名前を付けています。これをピボットテーブルのデータ ソースとして使用しているため、すべてが一度に更新され、数式は自動的に範囲を拡大して、追加された新しい行または列を含めます。ソースデータシート。

また、グループ化ポイントまで機能するからといって、ピボットフィールドの変数が正しく行われているとは限らないことも認識しています。

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 に答える