VBA复制外观function

下面的代码是为了创build一个泡沫饼图（一个饼图为泡泡的球形图）。 它recursion地将饼图复制到气泡图中。 我的问题是，用这种方法，最终的饼图看起来有点椭圆形 – 不是真的圆。 我怀疑这个问题与某种格式有关。

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 15\Theme Colors\Blue Green.xml" Const thmColor2 As String = "C:\Program Files\Microsoft Office\Document Themes 15\Theme Colors\Orange Red.xml" Select Case i Mod 2 Case 0 GetColorScheme = thmColor1 Case 1 GetColorScheme = thmColor2 End Select End Function 

我发现问题是可以解决的，如果双击特定的ubbleselect格式数据点，然后去填充和拉伸选项（只有select图片填充可能）。 问题是，我的数据正在改变，我需要一个dynamic的方式来实现上述代码..有办法做到这一点？

我在这里提到这个控制台http://s1.directupload.net/file/d/3300/7dlimc3g_png.htm

Answer 1

我认为这可能是问题，如果你的饼图不是一个完美的方形。 我可以复制你的问题，甚至当我检查填充选项，偏移量都是0% 。 我可以调整他们，但这不是一个可靠的方法来做到这一点。 所以，我认为最好的select是确保你的饼图.Parent是一个正方形。 为此，在CopyPicture之前，将其Height设置为其Width ，如下所示：

 chtMarker.Parent.Height = chtMarker.Parent.Width '## Ensure the chartObject is a square, so it will not be distorted when pasted. chtMarker.Parent.CopyPicture xlScreen, xlPicture