在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），并将其值分配给选择颜色主题时从宏录制器生成的文件路径。在此示例中，我只使用了两个，但只要在Case块中添加相应的Select，就可以使用其中的两个。

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