Excel VBA复制工作表后饼图出现倒角问题求助

问题背景 #

原本通过VBA复制包含饼图的工作表，能保证所有副本的饼图配色一致，功能正常。但经优化代码后，所有复制生成的工作表里的饼图都出现了原工作表没有的倒角效果，手动将倒角相关的宽度、高度参数设为0可恢复预期样式。

问题分析 #

当前代码中仅对饼图的顶部倒角做了禁用处理，但复制过程中图表可能继承或被意外设置了底部倒角属性，导致倒角效果残留。需要完整覆盖所有倒角相关的3D格式参数，才能彻底清除这个意外效果。

修正方案 #

完善图表3D格式的设置逻辑，同时禁用顶部和底部的倒角，并将所有相关参数清零，确保饼图保持平面样式：

Sub BCopyAllStudentsInclInfo()
Dim studentNo As Integer
Dim newStudentNo As Integer
Dim beforeIndex As Integer
Dim i As Integer
Dim newSheet As Worksheet
Dim targetSheetName As String

studentNo = 1
newStudentNo = 2
targetSheetName = "Student " & studentNo

' 查找"Student 1"工作表的索引
For i = 1 To Sheets.Count
    If Sheets(i).Name = targetSheetName Then
        beforeIndex = i
        Exit For
    End If
Next i

' 未找到则退出宏
If beforeIndex = 0 Then
    MsgBox "未找到工作表 '" & targetSheetName & "'!", vbExclamation
    Exit Sub
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

' 复制并重命名29个学生工作表
For i = 1 To 29
    Sheets("Student " & studentNo).Copy After:=Sheets(beforeIndex)

    Set newSheet = ActiveSheet
    newSheet.Name = "Student " & newStudentNo

    studentNo = studentNo + 1
    newStudentNo = newStudentNo + 1
    beforeIndex = beforeIndex + 1 ' 更新插入位置索引
Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "学生工作表复制与重命名完成!"


Dim Xvalue As Long: Xvalue = 52
Dim value As Long: value = 53
Dim wsStudent As Worksheet
Dim chtObj As ChartObject
Dim chartDataSheet As Worksheet
Dim chartNames As Variant
Dim chartRanges As Variant
Dim colors As Variant
Dim j As Long, p As Long, studentCount As Long

' 定义图表名称、数据源工作表及数据点数
chartNames = Array( _
    Array("Attend", "Attend", 5), _
    Array("Behave", "Behave", 4), _
    Array("Lang A CW", "Lang A CW", 4), _
    Array("Lang A HW", "Lang A HW", 4), _
    Array("ESL CW", "ESL  CW", 4), _
    Array("ESL HW", "ESL  HW", 4), _
    Array("Maths CW", "Maths CW", 4), _
    Array("Maths HW", "Maths HW", 4), _
    Array("Bio CW", "Bio CW", 4), _
    Array("Bio HW", "Bio HW", 4), _
    Array("Chem CW", "Chem CW", 4), _
    Array("Chem HW", "Chem HW", 4), _
    Array("Phys CW", "Phys CW", 4), _
    Array("Phys HW", "Phys HW", 4), _
    Array("Biz CW", "Biz CW", 4), _
    Array("Biz HW", "Biz HW", 4), _
    Array("FPM CW", "FPM CW", 4), _
    Array("FPM HW", "FPM HW", 4), _
    Array("ICT CW", "ICT CW", 4), _
    Array("ICT HW", "ICT HW", 4))

' 定义配色方案：绿、黄、橙、红、黑
colors = Array(RGB(0, 255, 0), RGB(255, 255, 0), RGB(255, 192, 0), RGB(255, 0, 0), RGB(0, 0, 0))

For studentCount = 1 To 30
    Set wsStudent = Worksheets("Student " & studentCount)

    For j = 0 To UBound(chartNames)
        Dim chartName As String: chartName = chartNames(j)(0)
        Dim dataSheetName As String: dataSheetName = chartNames(j)(1)
        Dim pointCount As Long: pointCount = chartNames(j)(2)

        On Error Resume Next
        Set chtObj = wsStudent.ChartObjects(chartName)
        Set chartDataSheet = Worksheets(dataSheetName)
        On Error GoTo 0

        If Not chtObj Is Nothing And Not chartDataSheet Is Nothing Then
            With chtObj.Chart
                On Error Resume Next
                With .ChartArea.Format.ThreeD
                    ' 禁用顶部倒角并清零参数
                    .BevelTopType = msoBevelNone
                    .BevelTopDepth = 0
                    .BevelTopInset = 0
                    ' 禁用底部倒角并清零参数
                    .BevelBottomType = msoBevelNone
                    .BevelBottomDepth = 0
                    .BevelBottomInset = 0
                    ' 彻底关闭3D可见性
                    .Visible = False
                End With
                On Error GoTo 0

                .ChartType = xlPie

                ' 设置图表数据
                .FullSeriesCollection(1).XValues = chartDataSheet.Range(chartDataSheet.Cells(2, Xvalue), chartDataSheet.Cells(1 + pointCount, Xvalue))
                .FullSeriesCollection(1).Values = chartDataSheet.Range(chartDataSheet.Cells(2, value), chartDataSheet.Cells(1 + pointCount, value))

                ' 应用配色
                For p = 1 To pointCount
                    With .FullSeriesCollection(1).Points(p).Format.Fill
                        .Visible = msoTrue
                        .ForeColor.RGB = colors(p - 1 + IIf(pointCount = 4 And p = 3, 1, 0))
                        .Transparency = 0
                        .Solid
                    End With
                Next p
            End With
        Else
            Debug.Print "学生工作表 " & wsStudent.Name & " 中缺失图表或数据源：" & chartName
        End If
    Next j

    value = value + 1
Next studentCount

MsgBox "所有学生图表更新完成!", vbInformation
End Sub

关键修改说明 #

• 新增了对BevelBottomType、BevelBottomDepth、BevelBottomInset的设置，确保底部倒角也被完全禁用
• 保持所有倒角相关的深度、内缩参数为0，避免任何3D效果残留
• 保留了原有的配色和数据更新逻辑，不影响原本的功能

内容的提问来源于stack exchange，提问作者Rene