vba ピボット、円グラフ対応2

円グラフ表示微調整

Function AggregateAndCopyData() As Long
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim sourceRow As Long
    Dim destRow As Long
    Dim sumRow3 As Double
    Dim sumRow6 As Double
    Dim i As Integer

    ' シートの設定
    Set sourceSheet = ThisWorkbook.Sheets("SourceSheetName") ' ソースシートの名前を設定
    Set destinationSheet = ThisWorkbook.Sheets("DestinationSheetName") ' 目的シートの名前を設定

    sourceRow = 1 ' ソースシートの開始行
    destRow = 5   ' 目的シートの開始行

    ' ソースシートをループ処理
    Do While sourceSheet.Cells(sourceRow, 2).Value <> ""
        ' 3行目の合計を計算
        sumRow3 = 0
        For i = 3 To 14 ' C列は3、N列は14に対応
            sumRow3 = sumRow3 + sourceSheet.Cells(sourceRow + 2, i).Value
        Next i

        ' 6行目の合計を計算
        sumRow6 = 0
        For i = 3 To 14
            sumRow6 = sumRow6 + sourceSheet.Cells(sourceRow + 5, i).Value
        Next i

        ' 目的シートにデータをコピー
        destinationSheet.Cells(destRow, 3).Value = sumRow3 ' 3列目に3行目の合計
        destinationSheet.Cells(destRow, 5).Value = sumRow6 ' 5列目に6行目の合計

        ' 次の行に進む
        sourceRow = sourceRow + 8
        destRow = destRow + 1
    Loop
        ' 最後の行の値を返す
    AggregateAndCopyData = destRow - 1
End Function

Sub CreatePivotTable(destinationSheet As Worksheet, dataRange As Range)
    Dim pivotTable As pivotTable

    ' ピボットテーブルの作成
    Set pivotTable = destinationSheet.PivotTables.Add( _
        PivotCache:=ThisWorkbook.PivotCaches.Create( _
            SourceType:=xlDatabase, _
            SourceData:=dataRange), _
        TableDestination:=destinationSheet.Range("K3"), _
        tableName:="PivotTable1")

    ' ピボットテーブルの設定
    With pivotTable
        .PivotFields("項目名").Orientation = xlRowField
        .PivotFields("合計").Orientation = xlDataField
    End With
    
    ' ピボットテーブル設定の調整
    Call AdjustPivotTableSettings(pivotTable)
    
End Sub


Sub AdjustPivotTableSettings(pivotTable As pivotTable)
    ' フィールドヘッダーを非表示にする
    pivotTable.DisplayFieldCaptions = False

    ' グランドトータルを非表示
    pivotTable.RowGrand = False
    pivotTable.ColumnGrand = False
End Sub

 

 

Sub CreateChart(chartSheet As Worksheet, pivotTable As pivotTable)
    Dim chart As chart
    Dim pivotRange As Range

    ' ピボットテーブルの範囲を取得
    Set pivotRange = pivotTable.TableRange2

    ' 円グラフの作成
    Set chart = chartSheet.Shapes.AddChart2( _
        Style:=5, _
        XlChartType:=xlPie, _
        Left:=100, Top:=100, Width:=375, Height:=225).chart

    ' グラフのデータ範囲を設定
    chart.SetSourceData Source:=pivotRange

    ' その他のグラフ設定
    With chart
        .HasTitle = False ' グラフタイトルを非表示にする

        ' データラベルの設定
        With .SeriesCollection(1).DataLabels
            .NumberFormat = "0%" ' パーセンテージ形式
            .ShowPercentage = True
            .ShowCategoryName = True ' カテゴリ名を表示
            .ShowValue = False ' 数値は非表示
        End With

        ' 不要な要素を非表示にする
        .HasLegend = False ' 凡例を非表示
        .HasDataTable = False ' データテーブルを非表示
    End With
End Sub


Sub DeleteSpecificChart(chartSheet As Worksheet, chartName As String)
    Dim chartObject As chartObject

    ' チャートシート上のグラフをループ処理
    For Each chartObject In chartSheet.ChartObjects
        If chartObject.Name = chartName Then
            chartObject.Delete
            Exit For
        End If
    Next chartObject
End Sub

 

Sub DeleteExistingPivotTable(destinationSheet As Worksheet, tableName As String)
    Dim pt As pivotTable

    For Each pt In destinationSheet.PivotTables
        If pt.Name = tableName Then
            pt.TableRange2.Clear
            Exit For
        End If
    Next pt
End Sub


Sub Main()
    Dim lastRow As Long
    Dim destinationSheet As Worksheet
    Dim chartSheet As Worksheet
    Dim dataRange As Range
    Dim pivotTable As pivotTable

    ' シートの設定
    Set destinationSheet = ThisWorkbook.Sheets("DestinationSheetName")
        
    On Error Resume Next
    Set chartSheet = ThisWorkbook.Sheets("ChartSheetName")
    On Error GoTo 0
    If chartSheet Is Nothing Then
        Set chartSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        chartSheet.Name = "ChartSheetName"
    End If


    ' 集計データを取得
    lastRow = AggregateAndCopyData()
    Set dataRange = destinationSheet.Range("B4:C" & lastRow)


    ' 既存のピボットテーブルがあれば削除
    Call DeleteExistingPivotTable(destinationSheet, "PivotTable1")


    ' ピボットテーブルを作成
    Call CreatePivotTable(destinationSheet, dataRange)
    Set pivotTable = destinationSheet.PivotTables("PivotTable1")

    ' 特定のグラフを削除
    'Call DeleteSpecificChart(chartSheet, "MyChart")
    ' 円グラフを作成
    Call CreateChart(chartSheet, pivotTable)
End Sub

 

・特定グラフ削除

Sub CreateChart(chartSheet As Worksheet, pivotTable As pivotTable)
    Dim chart As Chart
    Dim pivotRange As Range
    Dim chartObject As ChartObject

    ' 新しい円グラフの作成
    Set chartObject = chartSheet.Shapes.AddChart2( _
        Style:=5, _
        XlChartType:=xlPie, _
        Left:=100, Top:=100, Width:=375, Height:=225)
    Set chart = chartObject.Chart
    chart.Name = "MyChart" ' グラフに名前を設定

    ' グラフのデータ範囲を設定
    chart.SetSourceData Source:=pivotRange

    ' ... (他のグラフ設定)
End Sub

 

Sub DeleteSpecificChart(chartSheet As Worksheet, chartName As String)
    Dim chartObject As ChartObject

    ' チャートシート上のグラフをループ処理
    For Each chartObject In chartSheet.ChartObjects
        If chartObject.Name = chartName Then
            chartObject.Delete
            Exit For
        End If
    Next chartObject
End Sub