是否按标题移动饼图点

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

经过大量的修改和谷歌搜索，我已经找到了如何根据切片名称进行更改。

注意：

1. 名称字段会拉入所有名称信息。例如，如果你已经勾选了每个切片的"百分比"，也就是拉入名称--"十二月销售额；25%"。这需要在循环遍历名称时说明
2. 此宏位于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