Excel工作表复制时CustomProperties集合未被复制的原因及解决方法

问题描述 #

近期使用Excel.Worksheet.CustomProperties（区别于工作簿级的CustomDocumentProperties）存储工作表专属设置，用于VBA宏调用。但发现无论通过UI右键复制工作表，还是用VBA的Worksheet.Copy方法，目标工作表的CustomProperties集合始终为空，原工作表的自定义属性并未被复制。想确认这是微软的设计还是疏忽，设计原因是什么，以及UI复制时如何同步该集合。

核心结论 #

这是微软的设计行为，并非疏忽。

设计原因 #

• 工作表复制的核心逻辑是复制可见内容与基础结构（单元格数据、格式、内嵌对象、普通名称等），CustomProperties属于工作表的扩展元数据，被定位为开发者手动管理的自定义标记，而非工作表"内容"的一部分，因此不在默认复制范围内。
• 区分工作簿级与工作表级自定义属性的设计逻辑：CustomDocumentProperties随工作簿整体存在，而Worksheet.CustomProperties被视为与原工作表绑定的"私有标记"，默认不随复制迁移，避免无意识的元数据冗余或污染。

解决方法 #

1. VBA复制时手动同步 #

执行Worksheet.Copy后，遍历原工作表的CustomProperties，将属性逐一添加到新工作表。修改后的示例代码：

Public Sub CustomPropertyTestWithCopy()
    
    ' 在空白工作簿中运行此代码
        
    Dim xl          As Excel.Application
    Dim wb          As Excel.Workbook
    Dim wss         As Excel.Sheets
    Dim ws1         As Excel.Worksheet
    Dim cps1        As Excel.CustomProperties
    Dim cp1         As Excel.CustomProperty
    Dim ws2         As Excel.Worksheet
    Dim cps2        As Excel.CustomProperties
    Dim cp2Count    As Long
    Dim wsLast      As Long
    Dim cp          As Excel.CustomProperty

    Set xl = Excel.Application
    Set wb = xl.ActiveWorkbook
    Set wss = wb.Worksheets
    
    Set ws1 = wb.ActiveSheet
    Set cps1 = ws1.CustomProperties
    Set cp1 = cps1.Add("cpTestName", "cpTestValue")
    ' 原工作表已添加自定义属性
    
    wsLast = wss.Count
    ws1.Copy After:=wss.Item(wsLast)
    ' 复制工作表（UI操作对应右键"移动或复制..."）
    
    wsLast = wss.Count
    Set ws2 = wss.Item(wsLast)
    Set cps2 = ws2.CustomProperties

    ' 同步原工作表的CustomProperties到新表
    For Each cp In ws1.CustomProperties
        cps2.Add cp.Name, cp.Value
    Next cp

    cp2Count = cps2.Count
    ' 此时cp2Count = 1，自定义属性已成功复制

    Stop

End Sub

2. UI复制时自动同步 #

通过监听工作簿的事件，在新工作表创建时自动同步源工作表的CustomProperties。步骤如下：

1. 打开工作簿的ThisWorkbook代码模块，添加以下事件代码：

Private lastSheetName As String

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    ' 记录切换前的工作表名称，用于判断复制源
    If TypeName(Sh) = "Worksheet" Then
        lastSheetName = Sh.Name
    End If
End Sub

Private Sub Workbook_NewSheet(ByVal Sh As Object)
    Dim originalWs As Worksheet
    Dim cp As Excel.CustomProperty

    If TypeName(Sh) = "Worksheet" Then
        ' 获取之前激活的工作表（默认作为复制源）
        On Error Resume Next
        Set originalWs = Me.Worksheets(lastSheetName)
        On Error GoTo 0

        If Not originalWs Is Nothing Then
            ' 同步自定义属性
            For Each cp In originalWs.CustomProperties
                Sh.CustomProperties.Add cp.Name, cp.Value
            Next cp
        End If
    End If
End Sub

注意：该方案基于"用户复制前会先激活源工作表"的常规操作逻辑，若用户直接右键复制未激活的工作表，可通过对比工作表内容相似度等方式优化判断逻辑。

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