excel - スライサーを接続する VBA (コードの改善を探しています)

Question

最終的に、ピボットテーブルの更新時にスライサーを異なるキャッシュに接続するコードを見つけました。基本的に、slicer1 の値が変更されると、slicer2 が slicer1 と一致するように変更され、2 番目のスライサーに接続されているピボットテーブルが更新されます。

.Application.ScreenUpdatingマクロを高速化するためにandを追加し.Application.EnableEventsましたが、それでも動作が遅く、Excel が応答しなくなります。

これをコーディングするより直接的な方法はありますか、またはここに潜在的に揮発性の行があり、Excel が脳を揚げますか?

Private Sub Worksheet_PivotTableUpdate _
    (ByVal Target As PivotTable)
Dim wb As Workbook
Dim scShort As SlicerCache
Dim scLong As SlicerCache
Dim siShort As SlicerItem
Dim siLong As SlicerItem

Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo errHandler
Application.ScreenUpdating = False
Application.EnableEvents = False

Set wb = ThisWorkbook
Set scShort = wb.SlicerCaches("Slicer_Department")
Set scLong = wb.SlicerCaches("Slicer_Department2")

scLong.ClearManualFilter

For Each siLong In scLong.VisibleSlicerItems
    Set siLong = scLong.SlicerItems(siLong.Name)
    Set siShort = Nothing
    On Error Resume Next
    Set siShort = scShort.SlicerItems(siLong.Name)
    On Error GoTo errHandler
    If Not siShort Is Nothing Then
        If siShort.Selected = True Then
            siLong.Selected = True
        ElseIf siShort.Selected = False Then
            siLong.Selected = False
        End If
    Else
        siLong.Selected = False
    End If
Next siLong

exitHandler:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

errHandler:
    MsgBox "Could not update pivot table"
    Resume exitHandler
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Contextureで見つかった元のコード

いつもアドバイスありがとうございます。

元のお問い合わせへのリンク:

score 1 · Accepted Answer

ユーザーが一度に 1 つの項目だけを選択できるようにする場合は、PageFields で行う癖を活用する次のトリックを使用して、これを非常に迅速に行うことができます。これは、異なるキャッシュにある 3 つの異なるピボットテーブルを同期する例です。

マスターピボットテーブルごとにスレーブピボットテーブルを見えない場所に設定し、次のように、関心のあるフィールドをそれぞれに PageField として配置します。
これらのスレーブピボットテーブルのそれぞれについて、 [複数のアイテムを選択] チェックボックスがオフになっていることを確認します。
それらのスレーブのそれぞれにスライサーを追加します。繰り返しますが、これらは見えないところにあります。
これらの各スライサーを、最初に必要だった実際のピボットテーブルに接続します。(つまり、[レポート接続] ボックスを使用して、非表示の各スライサーを表示されている対応するピボットテーブルに接続します。

ここで巧妙なハックの出番です。ユーザーがクリックできるように、PivotTable1 Slave PivotTable に接続されているスライサーをメインシートに移動します。それを使用してアイテムを選択すると、そのPivotTable1 Slave PivotTableの PivotTable_Update イベントが生成されます。次に、他のスレーブピボットテーブルの .PageField をPivotTable1 スレーブピボットテーブルの .PageField と一致するように設定します。そして、さらに魔法が起こります。以前に設定した非表示のスライサーのおかげで、これらのスレーブ PageFields の単一選択がマスターピボットテーブルに複製されます。VBA は必要ありません。遅い繰り返しは必要ありません。まさに超高速同期。

セットアップ全体は次のようになります。

...これは、フィルタリングするフィールドがどのピボットにも表示されていない場合でも機能します。

これを実現するコードは次のとおりです。

Option Explicit

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

Dim pt As PivotTable
Dim pf As PivotField
Dim sCurrentPage As String
Dim vItem As Variant
Dim vArray As Variant

'########################
'# Change these to suit #
'########################

Const sField As String = "Name"
vArray = Array("PivotTable2 Slave", "PivotTable3 Slave")


If Target.Name = "PivotTable1 Slave" Then
    On Error GoTo errhandler
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    'Find out what item they just selected
    Set pf = Target.PivotFields(sField)
    With pf
        If .EnableMultiplePageItems Then
            .ClearAllFilters
            .EnableMultiplePageItems = False
            sCurrentPage = "(All)"
        Else:
            sCurrentPage = .CurrentPage
        End If
    End With

    'Change the other slave pivots to match. Slicers will pass on those settings
    For Each vItem In vArray
        Set pt = ActiveSheet.PivotTables(vItem)
        Set pf = pt.PivotFields(sField)
        With pf
            If .CurrentPage <> sCurrentPage Then
                .ClearAllFilters
                .CurrentPage = sCurrentPage
            End If
        End With
    Next vItem

errhandler:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End If

End Sub

ユーザーがスライサーで一度に複数の項目を選択できないようにするためのコードが少しあります。

しかし、ユーザーが複数のアイテムを選択できるようにしたい場合はどうでしょうか?

ユーザーが複数のアイテムを選択できるようにしたい場合、事態はさらに複雑になります。まず、各ピボットテーブルの ManualUpdate プロパティを TRUE に設定して、ピボットアイテムが変更されるたびに更新されないようにする必要があります。それでも、ピボットテーブルに 20,000 個のアイテムがある場合、1 つのピボットテーブルを同期するのに数分かかることがあります。多数の PivotItems を反復処理する際に、さまざまなアクションを実行するのにどれだけの時間がかかるかを示しているリンクを読むことをお勧めします: http://dailydoseofexcel. com/archives/2013/11/14/filtering-pivots-based-on-external-ranges/

それでも、何をしているかによっては、克服すべき課題が他にもたくさんあります。まず第一に、スライサーは物事を本当に遅くするようです。詳細については、 http://dailydoseofexcel.com/archives/2015/11/17/filtering-pivottables-with-vba-deselect-slicers-first/にある私の投稿をお読みください。

私は、このようなことの多くを電光石火の速さで行う商用アドインの立ち上げの最終段階にいますが、立ち上げには少なくとも 1 か月はかかります。

score 0 · Accepted Answer

何が間違っているのかわかりません。以下にコードを投稿しました。エラーは発生していません。他のスライサー/フィールドを更新していないだけです。最初のテストでは、Department スライサーはすべてのテーブルを 1 回更新しましたが、フィルターをクリアしたり、別の選択を許可したりしませんでした。Month スライサーに関しては、まったく機能しませんでした。個別に識別できるように、各アイテムを複製する必要があるのでしょうか? Dim sCurrentPage As StringおよびのようにDim sCurrentPage2 As String。スプレッドシートで作業しているときに、これほどひどい週末が来ることを望んだことはありませんでした。

Option Explicit

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

Dim pt As PivotTable
Dim pf As PivotField
Dim sCurrentPage As String
Dim vItem As Variant
Dim vArray As Variant
Dim sField As String

'########################
'# Change these to suit #
'########################

sField = "Department"
vArray = Array("PivotTable2 Slave", "PivotTable3 Slave")


If Target.Name = "PivotTable1 Slave" Then
    On Error GoTo errhandler
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    'Find out what item they just selected
    Set pf = Target.PivotFields(sField)
    With pf
        If .EnableMultiplePageItems Then
            .ClearAllFilters
            .EnableMultiplePageItems = False
            sCurrentPage = "(All)"
        Else:
            sCurrentPage = .CurrentPage
        End If
    End With

    'Change the other slave pivots to match. Slicers will pass on those settings
    For Each vItem In vArray
        Set pt = ActiveSheet.PivotTables(vItem)
        Set pf = pt.PivotFields(sField)
        With pf
            If .CurrentPage <> sCurrentPage Then
                .ClearAllFilters
                .CurrentPage = sCurrentPage
            End If
        End With
    Next vItem

'########################

sField = "Month"
vArray = Array("PivotTable2 Slave2", "PivotTable3 Slave2")


If Target.Name = "PivotTable1 Slave2" Then
    On Error GoTo errhandler
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    'Find out what item they just selected
    Set pf = Target.PivotFields(sField)
    With pf
        If .EnableMultiplePageItems Then
            .ClearAllFilters
            .EnableMultiplePageItems = False
            sCurrentPage = "(All)"
        Else:
            sCurrentPage = .CurrentPage
        End If
    End With

    'Change the other slave pivots to match. Slicers will pass on those settings
    For Each vItem In vArray
        Set pt = ActiveSheet.PivotTables(vItem)
        Set pf = pt.PivotFields(sField)
        With pf
            If .CurrentPage <> sCurrentPage Then
                .ClearAllFilters
                .CurrentPage = sCurrentPage
            End If
        End With
    Next vItem

errhandler:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End If

End Sub

excel - スライサーを接続する VBA (コードの改善を探しています)

2 に答える 2

Related

Reference