VBAで2つのスライサーを使った印刷

Question

実現したいこと

先日、マクロでスライサーのフィルタークリアの物を一部、スライサー項目別の物を一部ずつ印刷したいという問い合わせに回答頂き非常に感動した仕上がりの物をご教示頂きました。

今回、この応用でもう一つスライサーがあり2次抽出し、同じくフィルタークリアの物を一部、スライサー項目別の物を一部ずつ印刷したい。

発生している問題・分からないこと

苦戦している点が2段階構成になったことで抽出が上手くいかない事です。

例）
スライサー_日付：1124、1125、1126、、、と日付毎の抽出
スライサー_店舗コード：101、103、105、、、と店舗コードの抽出

日付が1124の時の店舗コード全クリアの物を1部、店舗コード項目別の物を1部ずつ、
続けて1125の時の店舗コード全クリアの物を1部、店舗コード項目別の物を1部ずつ
といった具合に日付の大分類ごとに店舗コードの各種を操作したいです。

該当のソースコード

Sub PrintSlicerFiltersAccurately_Final()
    Dim ws As Worksheet
    Dim slcCache As SlicerCache
    Dim slcItems As SlicerItems
    Dim s As slicerItem
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("印刷")
    ' スライサーキャッシュを取得
    On Error GoTo ErrHandler
    Set slcCache = ThisWorkbook.SlicerCaches("スライサー_店舗コード")
    On Error GoTo 0
    Set slcItems = slcCache.SlicerItems

    ' 1. フィルタークリア状態を印刷
    slcCache.ClearManualFilter
    ws.PrintOut Copies:=1                              ' フィルタークリア状態を1部印刷

    ' 2. 各スライサー項目ごとに1部ずつ印刷
    With slcItems
        For i = 1 To .Count
            If .Item(i).HasData Then
                slcCache.ClearManualFilter
                For Each s In slcItems
                    If .Item(i).Name <> s.Name Then
                        s.Selected = False
                    End If
                Next
                ws.PrintOut Copies:=1
            End If
        Next
    End With
    slcCache.ClearManualFilter
    Exit Sub
    
ErrHandler:
    MsgBox "スライサーが見つかりません", vbCritical
End Sub

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

ChatGPTやこちらの掲示板などを拝見して調べましたが解決策がわかりませんでした

補足

特になし

Answer 1

たぶん、こんな感じですかね？
前のはいまいちかも。
単一選択をサブルーチンに追い出せばロジックが分かりやすくなると思います。

Sub test()
    On Error GoTo WayOut
    With ThisWorkbook.SlicerCaches
        Dim slcCacheDate As SlicerCache: Set slcCacheDate = .Item("スライサー_日付")
        Dim slcCacheCode As SlicerCache: Set slcCacheCode = .Item("スライサー_販売先")
        Dim ws As Worksheet: Set ws = Worksheets("Sheet2")
    End With
    On Error GoTo 0
    Dim iDate As SlicerItem
    Dim iCode As SlicerItem
    
    Application.ScreenUpdating = False
    For Each iDate In slcCacheDate.SlicerItems
        SelectOnlyOne iDate
        slcCacheCode.ClearManualFilter
        ws.PrintPreview
        For Each iCode In slcCacheCode.SlicerItems
            SelectOnlyOne iCode
            ws.PrintPreview
        Next
    Next
    
    slcCacheDate.ClearManualFilter
    slcCacheCode.ClearManualFilter
    Exit Sub
    
WayOut:
    MsgBox "規定のオブジェクトが見つかりませんでした。"
End Sub

'単一選択
Private Sub SelectOnlyOne(ByRef pItem As SlicerItem)
    Dim slcCache As SlicerCache
    Dim s As SlicerItem
    
    Set slcCache = pItem.Parent
    slcCache.ClearManualFilter
    For Each s In slcCache.SlicerItems
        If s.Caption <> pItem.Caption Then
            s.Selected = False
        End If
    Next
End Sub

追記＞＞
ピボットの更新のマクロを書いてみました。
マクロのあるファイルと同じフォルダー内に他のアプリケーションから
CSVファイルを出力したと想定で書いてます。

Sub testPivot更新()
    Dim sFName As String
    Dim wbkData As Workbook
    Dim rngSource As Range
    Dim pvtTable As PivotTable
    
    ChDir ThisWorkbook.Path
    sFName = Application.GetOpenFilename("CSVファイル,*.csv")
    Set wbkData = Workbooks.Open(sFName)
    With wbkData.Worksheets(1).Range("A1").CurrentRegion
        Set rngSource = Intersect(.Cells, .Offset(1))
    End With
    
    Set pvtTable = ThisWorkbook.Worksheets(2).PivotTables(1)
    pvtTable.ChangePivotCache ThisWorkbook.PivotCaches. _
        Create(SourceType:=xlDatabase, SourceData:=rngSource)
    pvtTable.PivotCache.Refresh
    
    wbkData.Close False
End Sub

これでやったら、無い項目は綺麗に消えると思いますが、いかがでしょうか？

Comments

[con_mura]

早速のご回答ありがとうございます。
試してみたところ理想に近いものが出来ています！本当にすごい、、、！
ですが何点か不具合があったので修正にチャレンジしましたができませんでした。

例えばわかりやすく今回対象の日付を「5」販売先を「A/B/C...」としたとき、5-A～Zと5-A、5-B、5-Cと印刷掛けたいのですが、走らせたところ上記とプラスしてスライサーのグレーアウトしている今回対象項目でないものまでループしています。（明転している5-A～Zと5-A、5-B、5-Cが走った後、暗転している1-A～Z、1-A、2-A～Z、2-D、2-Eといった具合）

説明がおぼつかず申し訳ありません。何か解決策もらえたらうれしいです

[mattuwan]

マクロを実行する前の選択状況で、
個別に印刷したいということでしょうか？

（「今回対象項目でない。」というものがこちらではわかりません。）

[con_mura]

新規のcsvデータから既存のピボットテーブルを更新するところまでがマクロ実行前の動きです。
ここからマクロを実行して日付別明細と日付別店舗明細の印刷をかけたいです

[mattuwan]

あぁ、無くなった項目をスライサーの項目からなくしたいということですね。
ちょっと研究してみます。

[mattuwan]

slcCacheDate.SlicerCache.ShowAllItems = False

とかで、消せそうです。

https://learn.microsoft.com/ja-jp/office/vba/api/excel.slicercache.showallitems?f1url=%3FappId%3DDev11IDEF1%26l%3Dja-JP%26k%3Dk(vbaxl10.chm897088)%3Bk(TargetFrameworkMoniker-Office.Version%3Dv16)%26rd%3Dtrue

[con_mura]

ありがとうございます。こちら挿入してみましたところスライサーのキャッシュの削除には成功しましたが、なぜか印刷に移ったところで恐らくキャッシュ分の印刷までしているようです。
なかなか難しいですね。。。研究します！

[mattuwan]

あれー？サンプルデータがないので、ちょっと苦戦かもです。
頑張ってサンプルデータ作ってみます。

[mattuwan]

回答の方に追記しました。

[con_mura]

度々のご対応ありがとうございました
多少エラーが出ましたが根本のエクセルの修正等行い改善出来ました。
学びが多かったです！