VBAでスライサー項目ごとの印刷ができない

実現したいこと

RPAでCSVを取得し所定のExcelに読み取りピボットを更新、その後マクロを読み込んで更新されたピボットのスライサーを利用してフィルタクリアしたものを一部、スライサー項目ごとの物を一部ずつ印刷するVBAを作りたい。

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

フィルタークリアしたもの一部の印刷は成功するが、スライサー項目別の印刷がどうしてもうまくいかず、フィルタークリアの物が項目数分印刷されてしまう。
原因は画面が項目の選択をしきれてないまま印刷している事だと思うが、秒数の加減をしてもうまくできない。

また、このコードだとスライサーの項目ごとのループに入ったあと項目数以上に周回してしまいなかなか完了しない。

該当のソースコード

Sub PrintSlicerFiltersAccurately_Final()
    Dim ws As Worksheet
    Dim slicer As SlicerCache
    Dim slicerItem As slicerItem
    Dim slicerName As String
    Dim itemCount As Integer

    ' ピボットテーブルのあるシートを設定
    Set ws = ThisWorkbook.Sheets("印刷") ' シート名を変更

    ' スライサーの名前を設定
    slicerName = "スライサー_店舗コード" ' スライサー名を変更

    ' スライサーキャッシュを取得
    On Error Resume Next
    Set slicer = ThisWorkbook.SlicerCaches(slicerName)
    On Error GoTo 0

    If slicer Is Nothing Then
        MsgBox "スライサーが見つかりません", vbCritical
        Exit Sub
    End If

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

    ' 2. 各スライサー項目ごとに1部ずつ印刷
    itemCount = 0
    For Each slicerItem In slicer.SlicerItems
        ' データが存在する場合のみ進む
        If slicerItem.HasData Then
            ' スライサーを完全にリセット
            slicer.ClearManualFilter
            DoEvents ' Excelにリセットを認識させる

            ' 現在の項目だけを選択
            slicerItem.Selected = True
            DoEvents ' Excelに選択を認識させる

            ' 印刷実行
            ws.PrintOut Copies:=1
            Debug.Print "印刷完了：" & slicerItem.Name
            itemCount = itemCount + 1

            ' 現在の選択状態を解除
            slicerItem.Selected = False
            DoEvents ' 選択解除を反映
        End If
    Next slicerItem

    ' 最後にフィルターをクリア
    slicer.ClearManualFilter
    Debug.Print "すべての印刷が完了しました。印刷した項目数：" & itemCount
    MsgBox "すべての印刷が完了しました！", vbInformation
End Sub

試したこと・調べたこと

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

上記の詳細・結果

ChatGPTなどを利用して更新かけてはいるが改善されない

補足

Excel2019を利用

行動規範の内容に同意します

回答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("Sheet2")
    ' スライサーキャッシュを取得
    On Error GoTo ErrHandler
    Set slcCache = ThisWorkbook.SlicerCaches("スライサー_販売先")
    On Error GoTo 0
    Set slcItems = slcCache.SlicerItems

    ' 1. フィルタークリア状態を印刷
    slcCache.ClearManualFilter
    ws.PrintPreview                              ' フィルタークリア状態を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.PrintPreview
            End If
        Next
    End With
    slcCache.ClearManualFilter
    Exit Sub
    
ErrHandler:
    MsgBox "スライサーが見つかりません", vbCritical
End Sub

slcCache.ClearManualFilter
は、全部Trueになる。（１個も選択が内容にはできない。）

投稿2024/11/25 06:11