0

我的代码是

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 说指示的值超出范围..有人可以帮我这里出现的问题吗？

是否有任何方法可以集成饼图组件的显示（在每个饼图的列头中指示的组件名称，然后将其转移到气泡图？

4

1 回答 1

2

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

录制的宏会给你这样的东西（对于 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类的字符串变量，并将它们的值分配给您在选择颜色主题时从宏记录器生成的文件路径。在这个例子中，我只使用了两个，但你可以使用其中的许多，只要你在块中添加一个对应的。thmColor1thmColor2CaseSelect

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
于 2013-06-27T16:13:49.997 回答