[[20220930111254]]　『ピボットグラフ』（てんてん）　ページの最後に飛ぶ

『ピボットグラフ』（てんてん）

どなたかお教えいただきたいのですが
ピボットテーブルからピボットグラフにて職員の人事考課のデータ報告書
の作成を考えているのですが、部署ごとに可変式するとした場合に
人数分のレーダーパラメータ形式のグラフを一枚の紙に部署ごとに配置して
部署が変わればグラフの数も変更するようなデータを作りたいと思っております
その様なことは可能でしょうか？　一つのグラフですと今のところレーダデータは複数作成できない為、グラフ自体を参照セルあるいはスライサーで増減コントロールしたいです

＜使用 Excel：Office365、使用 OS：unknown ＞

 ピボットテーブルだと、
 一つのレーダーチャートに複数人のデータを系列として含む、
 一つのレーダーチャートが作られるはずです。

 仮に対象を一人に絞ったとしても、
 レーダーチャートを複数枚並列的に自動作成することはできないのでは？

 また、スライサーは一つのグラフの視点を変えていくもののようなので、
 あくまでもグラフは一つでしょう。

 人数分のレーダーチャートを作るなら、ピボットグラフを忘れたほうがいいかもしれませんね。
 　
（γ） 2022/09/30(金) 16:11

マクロが使えるなら
レーダーチャート作成→画像としてコピーペースト
の繰り返し処理ですかね。

（マナ） 2022/09/30(金) 17:20

↑の場合グラフはshapesで作った方が
無難でせうか

 .ChartObjects.Add
でやってみたのですが、初期化[前回の作成した画像化グラフ等削除]時
少しトラブっています。ごり押しで、解決は出来るのですが
心のどこかに不安が残っています。(￣▽￣)
ごり押し＝エラーが出て削除出来ないのですが、出来るまで
エラーを無視して繰り返し削除出来るまで、頑張るよ～な
ロジックになっています。。。＾＾；
m(_ _)m
Err.Description=指定したコレクションに対するインデックスが境界を超えています。
Err.Number=-2147024809 
Option Explicit
Sub OneInstanceMain()
    Const zProgramID As String = "IJ00500.xlsm"
    Dim ztb As Workbook
    Dim urr As Range
    Dim v() As Variant
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim y As Long
    Dim r As Range
    Dim crr As Range
    Dim prr As Range
    Dim pc As Object
    Dim ch As Object
    Dim zD As Object
    Dim mk() As Variant
    Dim t As Double
    t = Timer
    Set ztb = Workbooks(zProgramID)
    With ztb.Worksheets("Sheet1")
        Do
            i = i + 1
            If sHapesDelete(ztb) Then Exit Do
            If i Mod 32 = 0 Then DoEvents
        Loop
        i = 0
        Do
            i = i + 1
            If cHartObjectsDelete(ztb) Then Exit Do
            If i Mod 32 = 0 Then DoEvents
        Loop
        i = 0
        Set zD = CreateObject("Scripting.Dictionary")
        Set r = .Cells(1).CurrentRegion
        v = r.Value
        For i = 2 To UBound(v, 1)
            zD(v(i, 2)) = Empty
        Next
        If zD.Count = 0 Then End
        mk = zD.keys
        y = 15: x = 1
        For i = 0 To UBound(mk)
            Set urr = r.Rows(1)
            Set crr = .Cells(1, 11).Resize(10, 6)
            Set ch = .ChartObjects.Add(crr.Left, crr.Top, crr.Width, crr.Height)
            For j = 2 To UBound(v, 1)
                If v(j, 2) = mk(i) Then
                    Set urr = Union(urr, r.Rows(j))
                End If
                If j Mod 8 = 0 Then DoEvents
            Next
            With ch
                With .Chart
                    .SetSourceData urr
                    .ChartType = xlRadar
                    .HasTitle = True
                    .ChartTitle.Text = "賞与査定"
                End With
                .CopyPicture
                .Delete
            End With
            Application.Goto .Cells(y, x)
            .Paste
            Set prr = .Cells(y, x).Resize(10, 6)
            Set pc = .Shapes(i + 1)
            With pc
                .Left = prr.Left
                .Top = prr.Top
                .Width = prr.Width
                .Height = prr.Height
            End With
            x = x + 6
            Set urr = Nothing
            If i Mod 8 = 0 Then DoEvents
        Next
    End With
    If Not zD Is Nothing Then zD.RemoveAll
    Erase v, mk
    MsgBox "終了　" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Function sHapesDelete(ByVal ztb As Object) As Boolean
    sHapesDelete = False
    Dim i As Long
    On Error Resume Next
    With ztb.Worksheets("Sheet1")
        For i = 1 To .Shapes.Count
            .Shapes(i).Delete
        Next
        If .Shapes.Count = 0 Then
            sHapesDelete = True
        End If
    End With
    On Error GoTo 0
End Function
Private Function cHartObjectsDelete(ByVal ztb As Object) As Boolean
    cHartObjectsDelete = False
    Dim i As Long
    On Error Resume Next
    With ztb.Worksheets("Sheet1")
        For i = 1 To .ChartObjects.Count
            .ChartObjects(i).Delete
        Next
        If .ChartObjects.Count = 0 Then
            cHartObjectsDelete = True
        End If
    End With
    On Error GoTo 0
End Function
（隠居Z） 2022/10/01(土) 23:22

追記、使用したダミー情報です。
シート名 Sheet1

     |[A]  |[B]  |[C]       |[D]   |[E]   |[F] |[G]   |[H]   |[I]     
 [1] |氏名 |部署 |役職      |販売力|統率力|説明|協調性|貢献度|勤務評価
 [2] |名前7|部署4|アルバイト|     2|     9|  10|     1|     5|       3
 [3] |名前3|部署1|係長      |     8|     9|   6|     7|     1|       6
 [4] |名前4|部署1|課長      |     5|     2|   4|     6|     1|       1
 [5] |名前1|部署1|主任      |     2|     1|   1|     3|     9|       8
 [6] |名前6|部署3|嘱託      |     1|     1|   5|     7|     8|       4
 [7] |名前5|部署2|正社員    |     7|     2|   2|     8|     1|       7
 [8] |名前9|部署4|正社員    |     5|     9|   8|     1|    10|       1
 [9] |名前2|部署1|部長      |     2|     6|   8|    10|     5|       2
 [10]|名前8|部署4|臨時      |     5|     1|   5|     3|     6|       5
（隠居Z） 2022/10/01(土) 23:25

cHartObjectsDelete
は必要ないですね。
Shapesなのに削除出来ない場合が。。。発生するようです。

私のコーディングに問題ありでせうか？。。。(T.T)
（隠居Z） 2022/10/02(日) 07:39

ｗ　最近、わたし、ぼけてきたかも
ひょっとして、基本的な
For i = .Shapes.Count To 1 Step -1

    .Shapes(i).Delete
Next
こうしないと、いけなかったよ～です。。。(￣▽￣)
お騒がせ致しました。すみません。すみません。
おおお。はずかし～～～～＼(◎o◎)／！
m(__)m
（隠居Z） 2022/10/02(日) 07:47

 レーダーチャートを実務で使ったことがありませんので、
 どんなピボットなのかイメージできないのですが

 部署と氏名を、ページフィールドに配置し
 ピボットグラフも予め作成しておき
 マクロでは

 １）部署と氏名を入れ替え
 ２）グラフを画像としてコピー
 ３）場所をずらしながら貼り付け

 といった感じで考えていました。

 通常のグラフであれば、画像にしなくてもよいのですが、
 隠居Zさんのコードで、グラフは１個だけ用意しソース範囲を入れ替えていくイメージです。

（マナ） 2022/10/02(日) 08:23

 おはようございます。＾＾
という事で、作り直して見ました。＾＾；　...
m(_ _)m
Option Explicit
Sub OneInstanceMain()
    Dim urr           As Range
    Dim v()           As Variant
    Dim i             As Long
    Dim j             As Long
    Dim x             As Long
    Dim y             As Long
    Dim r             As Range
    Dim crr           As Range
    Dim prr           As Range
    Dim pc            As Object
    Dim ch            As Object
    Dim zD            As Object
    Dim mk()          As Variant
    Dim t             As Double
    t = Timer
    With Worksheets("Sheet1")
        For i = .Shapes.Count To 1 Step -1
            .Shapes(i).Delete
        Next
        Set zD = CreateObject("Scripting.Dictionary")
        Set r = .Cells(1).CurrentRegion
        v = r.Value
        For i = 2 To UBound(v, 1)
            zD(v(i, 2)) = Empty
        Next
        If zD.Count = 0 Then End
        mk = zD.keys
        y = 15
        x = 1
        Set crr = .Cells(1, 12).Resize(10, 6)
        Set ch = .ChartObjects.Add(crr.Left, crr.Top, crr.Width, crr.Height)
        For i = 0 To UBound(mk)
            Set urr = r.Rows(1)
            For j = 2 To UBound(v, 1)
                If v(j, 2) = mk(i) Then
                    Set urr = Union(urr, r.Rows(j))
                End If
                If j Mod 8 = 0 Then DoEvents
            Next
            With ch
                With .Chart
                    .SetSourceData urr
                    .ChartType = xlRadar
                    .HasTitle = True
                    .ChartTitle.Text = "調査室査定"
                End With
                .CopyPicture
            End With
            Application.Goto .Cells(y, x)
            .Paste
            Set prr = .Cells(y, x).Resize(10, 6)
            'シェイプズの一個目はグラフエリアなので2枚目[画像]から
            Set pc = .Shapes(i + 2)
            With pc
                .Left = prr.Left
                .Top = prr.Top
                .Width = prr.Width
                .Height = prr.Height
            End With
            x = x + 6
            Set urr = Nothing
            If i Mod 8 = 0 Then DoEvents
            ch.Chart.ChartArea.ClearContents
        Next
        Application.Goto .Cells(1)
        ch.Delete
    End With
    If Not zD Is Nothing Then zD.RemoveAll
    Erase v, mk
    MsgBox "終了　" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
（隠居Z） 2022/10/02(日) 09:43

隠居Zさんのようなデータとして

 ・シートPivotに、元データ、ピボットテーブル、ピボットグラフを用意

 部署    部署4
 氏名    名前8

 値
  販売力         5
  統率力         1
  説明           5
  協調性         3
  貢献度         6
  勤務評価       5

 ・ピボットグラフのサイズや書式を設定
 ・各部署の名前のシートを作成
 ・下記コードを、シートモジュールにコピペ

 Sub test()
    Dim ws As Worksheet
    Dim pvt As PivotTable, cho As ChartObject
    Dim v, hdr, m1 As Long, m2 As Long
    Dim k As Long, n As Long, y As Long, x As Long
    Dim 部署 As String, 氏名 As String

    On Error Resume Next
    For Each ws In Worksheets
        If ws.Name <> Me.Name Then
            ws.DrawingObjects.Delete
        End If
    Next
    On Error GoTo 0

    Set pvt = PivotTables(1)
    Set cho = ChartObjects(1)
    v = Range(Application.ConvertFormula(pvt.SourceData, xlR1C1, xlA1)).Value
    hdr = Application.Index(v, 1)
    m1 = Application.Match("部署", hdr, 0)
    m2 = Application.Match("氏名", hdr, 0)

    For k = 2 To UBound(v)
        部署 = v(k, m1)
        氏名 = v(k, m2)
        Set ws = Worksheets(部署)
        pvt.PivotFields(m1).CurrentPage = 部署
        pvt.PivotFields(m2).CurrentPage = 氏名
        cho.Chart.ChartTitle.Text = 氏名

        cho.CopyPicture
        ws.Paste

        n = ws.Shapes.Count
        y = (n - 1) \ 8
        x = (n - 1) Mod 8
        ws.Shapes(n).Top = y * (cho.Height + 5) + ws.Rows(2).Top
        ws.Shapes(n).Left = x * (cho.Width + 5) + ws.Columns(2).Left
    Next

 End Sub

（マナ） 2022/10/02(日) 13:34

コメント返信：

[ 一覧(最新更新順) ]

[[20220930111254]] 『ピボットグラフ』（てんてん） ページの最後に飛ぶ

[[20220930111254]]　『ピボットグラフ』（てんてん）　ページの最後に飛ぶ