在Excel中使用VBA作为饼图气泡图
我的代码是
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 该代码旨在改变在气泡图中用作泡泡的连续饼图的颜色主题。 所以该函数只是为了select一个颜色scheme，我以前保存为一个string，然后根据脚本的运行来更改它，以便第一个饼图有另一个颜色比下一个饼图…我得到在线上debugging代码时出现错误消息
ThisWorkbook.Theme.ThemeColorScheme.Load GetColorScheme（thmColor）
错误消息是运行时错误2147024809说指示值超出范围..任何人都可以帮助我什么似乎是这里的问题？
而且还有什么办法可以整合饼图组件的显示（每个饼图中列的头部所标示的组件的名称，然后传送到气泡图？
最简单的路线是在复制每个图表之前更改主题颜色。
logging的macros将给你这样的东西（对于Windows 7上的Excel 2010），我只select了两个，但是可以使用任意数量的这个，或者也可以创build自己的自定义主题：
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" _ )
要复制这些图像，请打开macros录制器，然后从function区（页面布局|颜色）中select一些配色scheme。 我认为这应该适用于Excel 2007+，尽pipe2007年的文件path与我的示例中的文件path不同。
现在，如何将这个应用到你的代码…有几种方法来做到这一点。 我将添加几个Conststringvariables，存储我们将使用的每个他们的path。 然后我将添加一个索引variables和一个函数，它将根据索引确定要使用的主题。
您将需要在function中添加额外的Case Stements，以适应不止两种颜色的主题，否则会出错。
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 。 在此函数中，添加像thmColor1和thmColor2这样的Conststringvariables，并将其值分配给您在selectColor Theme时从macroslogging器生成的文件path。 在这个例子中，我只使用了两个，但是可以使用其中的很多，只要在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