在 Excel 中使用 VBA 制作饼状气泡图

Question

我的代码是

Sub PieMarkers()

Dim chtMarker As Chart
Dim chtMain As Chart
Dim intPoint As Integer
Dim rngRow As Range
Dim lngPointIndex As Long
Dim thmColor As Long
Dim myTheme As String


Application.ScreenUpdating = False
Set chtMarker = ActiveSheet.ChartObjects("chtMarker").Chart
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart

Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart
Set rngRow = Range(ThisWorkbook.Names("PieChartValues").RefersTo)

For Each rngRow In Range("PieChartValues").Rows
    chtMarker.SeriesCollection(1).Values = rngRow
    ThisWorkbook.Theme.ThemeColorScheme.Load GetColorScheme(thmColor)
    chtMarker.Parent.CopyPicture xlScreen, xlPicture
    lngPointIndex = lngPointIndex + 1
    chtMain.SeriesCollection(1).Points(lngPointIndex).Paste
    thmColor = thmColor + 1
Next

lngPointIndex = 0

Application.ScreenUpdating = True
End Sub

Function GetColorScheme(i As Long) As String
Const thmColor1 As String = "C:\Program Files\Microsoft Office\Document Themes 14\Theme Colors\Blue Green.xml"
Const thmColor2 As String = "C:\Program Files\Microsoft Office\Document Themes 14\Theme Colors\Orange Red.xml"
    Select Case i
        Case 0
            GetColorScheme = thmColor1
        Case 1
            GetColorScheme = thmColor2
    End Select
End Function

该代码旨在更改连续饼图的颜色主题，这些饼图在气泡图中用作气泡。所以这个函数只是为了选择一个我之前保存为字符串的配色方案，然后根据脚本的运行来改变它，这样第一个饼图就比下一个饼图有另一种颜色......我确实得到了在该行调试代码时出现错误提示

ThisWorkbook.Theme.ThemeColorScheme.Load GetColorScheme(thmColor)

错误消息是运行时错误 2147024809，表示指示的值超出范围。有人可以帮我解决这里的问题吗？

还有没有什么方法可以整合饼图组件的显示（每个饼图的列头指示的组件名称，然后转移到气泡图？

Answer 1

最简单的方法是在复制每个图表之前更改主题颜色。

录制的宏会给你这样的东西（对于 Windows 7 上的 Excel 2010），我只选择两个，但你可以使用任意数量的宏，或者你也可以创建自己的自定义主题来使用：

ActiveWorkbook.Theme.ThemeColorScheme.Load ( _
    "C:\Program Files (x86)\Microsoft Office\Document Themes 14\Theme Colors\Apex.xml" _
    )
ActiveWorkbook.Theme.ThemeColorScheme.Load ( _
    "C:\Program Files (x86)\Microsoft Office\Document Themes 14\Theme Colors\Essential.xml" _
    )

要复制这些，请打开宏记录器，然后从功能区（页面布局 | 颜色）中选择一些配色方案。我认为这应该适用于 Excel 2007+，尽管 2007 的文件路径与我的示例中的不同。

现在，如何将它应用到您的代码中...有几种方法可以做到这一点。我将添加几个Const 字符串变量，存储我们将使用的每个变量的路径。然后我将添加一个索引变量和一个函数，该函数将根据索引确定要使用的主题。

您需要在函数中添加额外的Case 语句以容纳两个以上的颜色主题，否则会出错。

Sub PieMarkers()

Dim chtMarker As Chart
Dim chtMain As Chart
Dim intPoint As Integer
Dim rngRow As Range
Dim lngPointIndex As Long
Dim thmColor as Long
Dim myTheme as String


Application.ScreenUpdating = False
Set chtMarker = ActiveSheet.ChartObjects("chtMarker").Chart
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart

Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart
Set rngRow = Range(ThisWorkbook.Names("PieChartValues").RefersTo)

For Each rngRow In Range("PieChartValues").Rows
    chtMarker.SeriesCollection(1).Values = rngRow
    ThisWorkbook.Theme.ThemeColorScheme.Load GetColorScheme(thmColor) '## Call a function to get the color scheme location
    chtMarker.Parent.CopyPicture xlScreen, xlPicture
    lngPointIndex = lngPointIndex + 1
    chtMain.SeriesCollection(1).Points(lngPointIndex).Paste
    thmColor = thmColor + 1  '## Increment our index variable
Next

lngPointIndex = 0

Application.ScreenUpdating = True
End Sub

包括一个附加函数GetColorScheme。在此函数中，添加Const 字符串变量，如thmColor1 和thmColor2，并将它们的值分配给您在选择颜色主题时从宏记录器生成的文件路径。在本例中，我只使用了两个，但您可以使用其中的多个，只要在 Select 块中添加对应的 Case 即可。

Function GetColorScheme(i as Long) as String  '## Returns the path of a color scheme to load
    '## Currently set up to ROTATE between only two color schemes.
    '   You can add more, but you will also need to change the 
    '   Select Case i Mod 2, to i Mod n; where n = the number 
    '   of schemes you will rotate through.
    Const thmColor1 as String = "C:\Program Files (x86)\Microsoft Office\Document Themes 14\Theme Colors\Apex.xml"
    Const thmColor2 as String = "C:\Program Files (x86)\Microsoft Office\Document Themes 14\Theme Colors\Essential.xml"


    Select Case i Mod 2  '## i Mod n; where n = the number of Color Schemes.
        case 0
            GetColorScheme = thmColor1
        case 1
            GetColorScheme = thmColor2
        'Case n  '## You should have an additional case for each 1 to n.
        '
    End Select
End Function