Excel 2013 VBA粘贴组合形状至气泡图系列：分步正常全速运行异常求助

问题出在依赖Select/Activate切换对象，加上全速运行时剪贴板同步有延迟——分步运行时手动等待给了Excel足够时间处理复制和对象切换，全速跑就没这个缓冲了。下面是修正后的可靠代码：

推荐方案（无Select/Activate，稳定性最高） #

Sub PasteShapesToChartPoints()
    Dim targetWs As Worksheet
    Dim chartObj As ChartObject
    Dim targetChart As Chart
    Dim group11 As Shape
    Dim group12 As Shape
    Dim targetPoint1 As Point
    Dim targetPoint2 As Point
    
    ' 替换成你的目标工作表名称，比如"数据Sheet"
    Set targetWs = ThisWorkbook.Worksheets("Sheet1")
    ' 绑定气泡图对象
    Set chartObj = targetWs.ChartObjects("Split Circle Chart")
    Set targetChart = chartObj.Chart
    
    ' 获取要复制的组合形状
    Set group11 = targetWs.Shapes("Group 11")
    Set group12 = targetWs.Shapes("Group 12")
    
    ' 把Group11粘贴到第1系列第1个点
    Set targetPoint1 = targetChart.FullSeriesCollection(1).Points(1)
    group11.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    targetPoint1.Fill.UserPicture group11.Picture
    
    ' 把Group12粘贴到第2系列第2个点
    Set targetPoint2 = targetChart.FullSeriesCollection(2).Points(2)
    group12.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    targetPoint2.Fill.UserPicture group12.Picture
    
    ' 清理剪贴板状态
    Application.CutCopyMode = False
End Sub

备选方案（兼容特殊形状组合） #

如果上面的UserPicture方法对某些复杂组合形状不生效，可改用带同步等待的版本：

Sub PasteShapesToChartPoints_Fallback()
    Dim targetWs As Worksheet
    Dim chartObj As ChartObject
    Dim targetChart As Chart
    Dim group11 As Shape
    Dim group12 As Shape
    
    Set targetWs = ThisWorkbook.Worksheets("Sheet1")
    Set chartObj = targetWs.ChartObjects("Split Circle Chart")
    Set targetChart = chartObj.Chart
    
    Set group11 = targetWs.Shapes("Group 11")
    Set group12 = targetWs.Shapes("Group 12")
    
    ' 处理第1个点
    group11.Copy
    ' 等待剪贴板完成复制
    Do Until Application.CutCopyMode = xlCopy
        DoEvents
    Loop
    targetChart.FullSeriesCollection(1).Points(1).Select
    DoEvents ' 给Excel时间切换到目标点
    targetWs.PasteSpecial Format:=1
    Application.CutCopyMode = False
    
    ' 处理第2个点
    group12.Copy
    Do Until Application.CutCopyMode = xlCopy
        DoEvents
    Loop
    targetChart.FullSeriesCollection(2).Points(2).Select
    DoEvents
    targetWs.PasteSpecial Format:=1
    Application.CutCopyMode = False
End Sub

核心优化点 #

• 抛弃Select/Activate：直接绑定对象，避免Excel对象切换时的混乱
• 添加同步等待：用DoEvents循环确保剪贴板复制完成，解决全速运行的延迟问题
• 改用Fill.UserPicture：绕过PasteSpecial的兼容性坑，更稳定地给图表点填充形状

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