复制工作表至另一工作簿后，修正ActiveX控件、形状及图表引用问题

现有两个工作簿workbook1和workbook2，需将workbook1中的「Board」工作表复制到workbook2。该工作表包含：

• 关联宏子程序的ActiveX控件
• 关联单元格值或宏的形状（圆角矩形、八边形等）及图片
• 关联单元格区域的Charts

复制后所有子程序、形状公式仍指向源工作簿workbook1（目标工作簿已存在所有引用工作表及调用过程），需修正为指向workbook2。当前遇到的问题：

• 现有宏仅成功复制工作表并修正ActiveX控件的宏引用
• 处理其他形状时，在If shp.Formula <> "" Then行出现运行时错误'438'：对象不支持该属性或方法
• 图表修正代码无效果
• 尝试通过选择形状加错误处理的方式，仍无法处理图片公式及组合形状

解决方案 #

1. 修复形状/图片/组合形状的引用 #

错误核心是并非所有形状都支持Formula属性（比如图片、组合形状的子元素），需要针对性判断对象类型，同时遍历组合形状内部元素：

Sub FixShapeReferences(targetSheet As Worksheet, sourceWBName As String, targetWBName As String)
    Dim shp As Shape
    Dim subShp As Shape
    Dim oldRef As String, newRef As String
    
    oldRef = "'" & sourceWBName & "'!"
    newRef = "'" & targetWBName & "'!"
    
    For Each shp In targetSheet.Shapes
        ' 处理组合形状内的子形状
        If shp.Type = msoGroup Then
            For Each subShp In shp.GroupItems
                FixSingleShapeFormula subShp, oldRef, newRef
            Next subShp
        Else
            FixSingleShapeFormula shp, oldRef, newRef
        End If
    Next shp
End Sub

Private Sub FixSingleShapeFormula(shp As Shape, oldRef As String, newRef As String)
    On Error Resume Next ' 跳过不支持Formula属性的对象
    Dim currentFormula As String
    currentFormula = shp.Formula
    If Err.Number = 0 Then
        If InStr(currentFormula, oldRef) > 0 Then
            shp.Formula = Replace(currentFormula, oldRef, newRef)
        End If
    End If
    Err.Clear
    On Error GoTo 0
    
    ' 修复形状的宏关联（动作设置）
    On Error Resume Next
    If shp.OnAction <> "" Then
        shp.OnAction = Replace(shp.OnAction, sourceWBName & "!", targetWBName & "!")
    End If
    Err.Clear
    On Error GoTo 0
End Sub

2. 修复图表数据源引用 #

图表需要逐个修改系列的数据源公式，而非仅处理图表对象本身：

Sub FixChartReferences(targetSheet As Worksheet, sourceWBName As String, targetWBName As String)
    Dim cht As ChartObject
    Dim ser As Series
    Dim oldRef As String, newRef As String
    
    oldRef = "'" & sourceWBName & "'!"
    newRef = "'" & targetWBName & "'!"
    
    For Each cht In targetSheet.ChartObjects
        For Each ser In cht.Chart.SeriesCollection
            On Error Resume Next
            ' 修复系列数据源公式
            ser.Formula = Replace(ser.Formula, oldRef, newRef)
            ' 修复系列名称的引用
            ser.Name = Replace(ser.Name, oldRef, newRef)
            Err.Clear
            On Error GoTo 0
        Next ser
    Next cht
End Sub

3. 完整调用流程 #

整合复制工作表、修复ActiveX、形状、图表的逻辑：

Sub CopyAndFixBoardSheet()
    Dim sourceWB As Workbook, targetWB As Workbook
    Dim sourceSheet As Worksheet, targetSheet As Worksheet
    Dim sourceWBName As String, targetWBName As String
    
    ' 替换为实际工作簿名称/路径
    Set sourceWB = Workbooks("workbook1.xlsm")
    Set targetWB = Workbooks("workbook2.xlsm")
    sourceWBName = sourceWB.Name
    targetWBName = targetWB.Name
    
    ' 复制工作表到目标工作簿
    sourceWB.Sheets("Board").Copy After:=targetWB.Sheets(targetWB.Sheets.Count)
    Set targetSheet = targetWB.Sheets(targetWB.Sheets.Count)
    
    ' 修复ActiveX控件宏引用（保留你原有的有效代码）
    FixActiveXReferences targetSheet, sourceWBName, targetWBName
    
    ' 修复形状及图片的公式、宏引用
    FixShapeReferences targetSheet, sourceWBName, targetWBName
    
    ' 修复图表数据源引用
    FixChartReferences targetSheet, sourceWBName, targetWBName
End Sub

' 保留你原有的ActiveX修复代码（可根据实际控件类型调整）
Sub FixActiveXReferences(targetSheet As Worksheet, sourceWBName As String, targetWBName As String)
    Dim oleObj As OLEObject
    For Each oleObj In targetSheet.OLEObjects
        If oleObj.progID Like "*Forms.*" Then
            oleObj.Object.OnAction = Replace(oleObj.Object.OnAction, sourceWBName & "!", targetWBName & "!")
        End If
    Next oleObj
End Sub

关键说明 #

• 用On Error Resume Next跳过不支持Formula属性的对象（如图片），避免438错误
• 组合形状必须遍历GroupItems子元素，才能修复内部引用
• 图表需逐个处理系列的Formula，才能彻底修正数据源指向

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