Question

我正在尝试遍历饼图上的每个点并将特定点移至第二个图，但是，我似乎无法弄清楚如何通过其标题引用图点？这可能吗？请在下面找到我的代码。

Sub FixPieSlices()
Dim chtCombined As ChartObject, chtABC As ChartObject, chtXYZ As ChartObject
Dim ws As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Set workbook and charts
Set ws = ThisWorkbook.Sheets("DB")

With ws
    Set chtCombined = .ChartObjects("PieAll")
    Set chtABC = .ChartObjects("PieABC")
    Set chtXYZ = .ChartObjects("PieXYZ")
End With

With chtCombined.Chart.FullSeriesCollection(1)
    .Points(1).SecondaryPlot = 0
    .Points(2).SecondaryPlot = 0
    .Points(3).SecondaryPlot = 0
    For i = 4 To .Points.Count
        .Points(i).SecondaryPlot = 1
    Next i
End With

With chtABC.Chart.FullSeriesCollection(1)
    .Points(1).SecondaryPlot = 0
    For i = 2 To .Points.Count
        .Points(i).SecondaryPlot = 1
    Next i
End With

With chtXYZ.Chart.FullSeriesCollection(1)
    .Points(1).SecondaryPlot = 0
    .Points(2).SecondaryPlot = 0
    For i = 3 To .Points.Count
        .Points(i).SecondaryPlot = 1
    Next i
End With

End Sub

Answer 1

很容易找到自己的解决方案：）

只是想向您展示如何缩短代码

Private Sub Workbook_SheetPivotTableUpdate(ByVal Sh As Object, ByVal Target As PivotTable)

    ' Reorganize slice/plots of pie charts on pivot table updates
    ' (changing of slicers triggers the macro)

    Dim chartNames As Variant
    chartNames = Array("PieAll", "PieABC", "PieXYZ")

    Dim j As Long
    Dim i As Long

    Application.ScreenUpdating = False

    'Loop through each chart, move slices not named 'Financial' to second plot
    'Then remove point explosion for all slices that aren't 'Other'
    For j = 0 To UBound(chartNames, 1)

         With ThisWorkbook.Sheets("DB").ChartObjects(chartNames(j)).Chart.FullSeriesCollection(1)
            For i = 1 To .Points.count
                If Not .Points(i).DataLabel.Caption Like "*Financial*" Then
                    .Points(i).SecondaryPlot = 1
                Else
                    .Points(i).SecondaryPlot = 0
                End If

                If .Points(i).DataLabel.Caption Like "Other*" Then
                    .Points(i).Explosion = 10
                Else
                    .Points(i).Explosion = 0
                End If
            Next i
        End With

    Next j

    Application.ScreenUpdating = True

End Sub

Answer 2

经过大量的修补和谷歌搜索，我想出了如何根据切片名称进行更改的方法。

注释：

名称字段将提取所有名称信息。因此，例如，如果您在每个切片上都勾选了“百分比”，这也将是取名为-“ December Sales; 25％”。这需要遍历名称时占的比例。
此宏位于ThisWorkbook模块中。这使它能够每次更改切片器/数据透视表时都会触发。

在下面找到更新的代码：

Private Sub Workbook_SheetPivotTableUpdate(ByVal Sh As Object, ByVal Target As PivotTable)

' Reorganize slice/plots of pie charts on pivot table updates
' (changing of slicers triggers the macro)

Dim chtCombined As ChartObject, chtABC As ChartObject, chtXYZ As ChartObject
Dim ws As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Set workbook and charts
Set ws = ThisWorkbook.Sheets("DB")

With ws
    Set chtCombined = .ChartObjects("PieAll")
    Set chtABC = .ChartObjects("PieABC")
    Set chtXYZ = .ChartObjects("PieXYZ")
End With

'Loop through each chart, move slices not named 'Financial' to second plot
'Then remove point explosion for all slices that aren't 'Other'
 With chtCombined.Chart.FullSeriesCollection(1)
    For i = 1 To .Points.Count
        If Not .Points(i).DataLabel.Caption Like "*Financial*" Then
            .Points(i).SecondaryPlot = 1
        Else
            .Points(i).SecondaryPlot = 0
        End If

        If .Points(i).DataLabel.Caption Like "Other*" Then
            .Points(i).Explosion = 10
        Else
            .Points(i).Explosion = 0
        End If
    Next i
End With

With chtABC.Chart.FullSeriesCollection(1)
    For i = 1 To .Points.Count
        If Not .Points(i).DataLabel.Caption Like "*Financial*" Then
            .Points(i).SecondaryPlot = 1
        Else
            .Points(i).SecondaryPlot = 0
        End If

        If .Points(i).DataLabel.Caption Like "Other*" Then
            .Points(i).Explosion = 10
        Else
            .Points(i).Explosion = 0
        End If
    Next i
End With

With chtXYZ.Chart.FullSeriesCollection(1)
    For i = 1 To .Points.Count
        If Not .Points(i).DataLabel.Caption Like "*Financial*" Then
            .Points(i).SecondaryPlot = 1
        Else
            .Points(i).SecondaryPlot = 0
        End If

        If .Points(i).DataLabel.Caption Like "Other*" Then
            .Points(i).Explosion = 10
        Else
            .Points(i).Explosion = 0
        End If
    Next i
End With

Application.ScreenUpdating = True
End Sub

按标题移动饼图点？

2 个答案: