设置图表类型xlDoughnut时与图表类型相关的问题

如何解决设置图表类型xlDoughnut时与图表类型相关的问题

我写了一个宏来动态填充甜甜圈图。我需要甜甜圈之外的数据标签。我能够实现此目标的唯一方法是将数据分配给类型为xlPie的图表并运行另一个宏。之后设置.ChartGroups(1).DoughnutHoleSize似乎是一种解决方法，可以将图表外观更改为甜甜圈，同时保留数据标签的位置。如果将图表类型设置为xlDoughnut，则数据标签将再次更改位置。

我的问题是，当我将生成的图表复制并粘贴到另一张纸上时，副本将还原为xlPie图表，即没有甜甜圈孔。因此，我尝试在饼图上添加一个圆形以使其成为甜甜圈。这种情况下的问题是图表的标题隐藏在圆形下方。

文件的其他用户必须定期将图表从生成位置复制并粘贴到另一个文件中，我希望粘贴的图表看起来像带有可见标题的甜甜圈。我怎样才能达到我想要的？以下是两个子项目，分别展示了每种情况。我的想法是：

在createChart_fakeDoughnut1()中，当手动复制并粘贴图表时保留格式，或者

在createChart_fakeDoughnut2()中

将标题设置为添加的圆形上方。

我不知道如何实现这两个目标。解释为什么fakeDoughnut1粘贴时会更改其格式。

Sub createChart_fakeDoughnut1()
    If ActiveSheet.ChartObjects.Count > 0 Then ActiveSheet.ChartObjects.Delete
    Dim chrt As ChartObject
    Dim dataRng As Range

    Dim lft As Integer
        lft = ActiveSheet.Range("D2").Left
    Dim wdth As Integer
        wdth = 500
    Dim hgt As Integer
        hgt = 300
    Dim tp As Integer
        tp = ActiveSheet.Range("D2").Top
    
    Set chrt = ActiveSheet.ChartObjects.Add(Left:=lft,Width:=wdth,Height:=hgt,Top:=tp)
    Dim i As Integer
    For i = 1 To 10
        ActiveSheet.Cells(i,1).Value = "A" & i
        With ActiveSheet.Cells(i,2)
            .Value = i / 55
            .NumberFormat = "0.00%"
        End With
    Next i
    Set dataRng = Range("A1:B10")

    With chrt.Chart
        .ChartType = xlPie
        .SetSourceData Source:=dataRng
        .HasTitle = True
        .ChartTitle.IncludeInLayout = False
        With .ChartTitle
            .Text = "Test"
            .Top = hgt / 2 - 20
            .Left = wdth / 2 - 20
        End With
        .HasLegend = False

    ' set hole size here    
    .ChartGroups(1).DoughnutHoleSize = 50
    End With
End Sub

Sub createChart_fakeDoughnut2()
    If ActiveSheet.ChartObjects.Count > 0 Then ActiveSheet.ChartObjects.Delete
    Dim chrt As ChartObject
    Dim dataRng As Range

    Dim lft As Integer
        lft = ActiveSheet.Range("D2").Left
    Dim wdth As Integer
        wdth = 500
    Dim hgt As Integer
        hgt = 300
    Dim tp As Integer
        tp = ActiveSheet.Range("D2").Top
    
    Set chrt = ActiveSheet.ChartObjects.Add(Left:=lft,2)
            .Value = i / 55
            .NumberFormat = "0.00%"
        End With
    Next i
    Set dataRng = Range("A1:B10")

    With chrt.Chart
        .ChartType = xlPie
        .SetSourceData Source:=dataRng
        .HasTitle = True
        With .ChartTitle
            .Text = "Test"
            .Top = hgt / 2 - 20
            .Left = wdth / 2 - 20
        End With
        .HasLegend = False

        ' add circle form here
        Dim x As Double,y As Double,h As Double,cd As Double
        With .PlotArea
            x = .Left
            y = .Top
            h = .Height
        End With
            cd = 120
        Dim circ As Shape
        Set circ = .Shapes.AddShape(msoShapeOval,x + h / 2 - cd / 2,_
        y + h / 2 - cd / 2,cd,cd)
        With circ
            .Line.Visible = msoFalse
            .Fill.ForeColor.RGB = RGB(255,255,255)
        End With
    End With
End Sub

解决方法

最好再插入一个正方形。

Sub createChart_fakeDoughnut2()
    If ActiveSheet.ChartObjects.Count > 0 Then ActiveSheet.ChartObjects.Delete
    Dim chrt As ChartObject
    Dim dataRng As Range

    Dim lft As Integer
        lft = ActiveSheet.Range("D2").Left
    Dim wdth As Integer
        wdth = 500
    Dim hgt As Integer
        hgt = 300
    Dim tp As Integer
        tp = ActiveSheet.Range("D2").Top
    
    Set chrt = ActiveSheet.ChartObjects.Add(Left:=lft,Width:=wdth,Height:=hgt,Top:=tp)
    Dim i As Integer
    For i = 1 To 10
        ActiveSheet.Cells(i,1).Value = "A" & i
        With ActiveSheet.Cells(i,2)
            .Value = i / 55
            .NumberFormat = "0.00%"
        End With
    Next i
    Set dataRng = Range("A1:B10")

    With chrt.Chart
        .ChartType = xlPie
        .SetSourceData Source:=dataRng
'        .HasTitle = True
'        With .ChartTitle
'            .Text = "Test"
'            .Top = hgt / 2 - 20
'            .Left = wdth / 2 - 20
'        End With
        .HasLegend = False

        ' add circle form here
        Dim x As Double,y As Double,h As Double,cd As Double,w As Double
        With .PlotArea
            x = .Left
            y = .Top
            h = .Height
            w = .Width
        End With
            cd = 120
        Dim circ As Shape
        Set circ = .Shapes.AddShape(msoShapeOval,x + h / 2 - cd / 2,_
        y + h / 2 - cd / 2,cd,cd)
        With circ
            .Line.Visible = msoFalse
            .Fill.ForeColor.RGB = RGB(255,255,255)
        End With
        Dim Rect As Shape
        Set Rect = .Shapes.AddShape(msoShapeRectangle,x + w / 2 - 20,y + h / 2 - 10,40,20)
        With Rect
            .Line.Visible = msoFalse
            .Fill.ForeColor.RGB = RGB(255,255)
            .TextFrame2.TextRange = "Test"
            With .TextFrame2.TextRange.Font
                .Bold = msoCTrue
                .Size = 18
                With .Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(0,0)
                End With
            End With
            .TextFrame.AutoSize = True
        End With
    End With
End Sub