如何调整VBA代码，拆分工作表到多工作簿并保留格式与保护

以下是针对需求调整后的完整代码，同时优化了原代码的执行效率（去除不必要的Select/Activate操作）：

Sub SplitSheetIntoMultipleWorkbooksBasedOnColumn()
    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow, nRow, nNextRow As Integer
    Dim strColumnValue As String
    Dim objDictionary As Object
    Dim varColumnValues As Variant
    Dim varColumnValue As Variant
    Dim objExcelWorkbook As Excel.Workbook
    Dim objSheet As Excel.Worksheet
    ' 新增变量存储原工作表保护设置
    Dim isSheetProtected As Boolean
    Dim protectPassword As String
    Dim allowFormatCells As Boolean
    Dim allowFormatColumns As Boolean
    Dim allowFormatRows As Boolean
    Dim allowInsertColumns As Boolean
    Dim allowInsertRows As Boolean
    Dim allowInsertHyperlinks As Boolean
    Dim allowDeleteColumns As Boolean
    Dim allowDeleteRows As Boolean
    Dim allowSort As Boolean
    Dim allowFilter As Boolean
    Dim allowUsePivotTables As Boolean

    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
    
    ' 读取原工作表的保护设置
    isSheetProtected = objWorksheet.ProtectContents
    If isSheetProtected Then
        protectPassword = objWorksheet.ProtectionPassword
        allowFormatCells = objWorksheet.Protection.AllowFormatCells
        allowFormatColumns = objWorksheet.Protection.AllowFormatColumns
        allowFormatRows = objWorksheet.Protection.AllowFormatRows
        allowInsertColumns = objWorksheet.Protection.AllowInsertColumns
        allowInsertRows = objWorksheet.Protection.AllowInsertRows
        allowInsertHyperlinks = objWorksheet.Protection.AllowInsertHyperlinks
        allowDeleteColumns = objWorksheet.Protection.AllowDeleteColumns
        allowDeleteRows = objWorksheet.Protection.AllowDeleteRows
        allowSort = objWorksheet.Protection.AllowSort
        allowFilter = objWorksheet.Protection.AllowFilter
        allowUsePivotTables = objWorksheet.Protection.AllowUsePivotTables
    End If

    Set objDictionary = CreateObject("Scripting.Dictionary")
    For nRow = 2 To nLastRow
        strColumnValue = objWorksheet.Range("A" & nRow).Value
        If Not objDictionary.Exists(strColumnValue) Then
           objDictionary.Add strColumnValue, 1
        End If
    Next

    varColumnValues = objDictionary.Keys
    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
        Set objExcelWorkbook = Excel.Application.Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name

        ' 复制表头并完整粘贴格式、内容及单元格属性（包括锁定）
        objWorksheet.Rows(1).EntireRow.Copy
        objSheet.Range("A1").PasteSpecial xlPasteAll
        Application.CutCopyMode = False ' 清除剪贴板

        ' 复制对应数据行
        For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range("A" & nRow).Value) = CStr(varColumnValue) Then
               objWorksheet.Rows(nRow).EntireRow.Copy
               nNextRow = objSheet.Range("A" & objSheet.Rows.Count).End(xlUp).Row + 1
               objSheet.Range("A" & nNextRow).PasteSpecial xlPasteAll
               Application.CutCopyMode = False
            End If
        Next

        ' 自动调整列宽
        objSheet.Columns("A:F").AutoFit

        ' 应用原工作表的保护设置到新工作表
        If isSheetProtected Then
            objSheet.Protect _
                Password:=protectPassword, _
                AllowFormatCells:=allowFormatCells, _
                AllowFormatColumns:=allowFormatColumns, _
                AllowFormatRows:=allowFormatRows, _
                AllowInsertColumns:=allowInsertColumns, _
                AllowInsertRows:=allowInsertRows, _
                AllowInsertHyperlinks:=allowInsertHyperlinks, _
                AllowDeleteColumns:=allowDeleteColumns, _
                AllowDeleteRows:=allowDeleteRows, _
                AllowSort:=allowSort, _
                AllowFilter:=allowFilter, _
                AllowUsePivotTables:=allowUsePivotTables
        End If
    Next
End Sub

关键修改说明 #

1. 完整复制格式与锁定单元格

   • 将原代码中的普通Paste替换为PasteSpecial xlPasteAll，该参数会复制源单元格的所有内容、格式、条件格式及单元格保护属性（包括Locked状态），确保表头颜色、单元格锁定等设置完全同步。
   • 新增Application.CutCopyMode = False清除剪贴板，避免后续操作受剪贴板内容影响。

2. 复制工作表保护设置

   • 新增变量存储原工作表的保护状态、密码及各项允许操作的权限（如允许格式设置、排序筛选等）。
   • 在生成新工作簿后，根据原工作表的保护参数，对新工作表执行相同的保护设置，确保权限完全一致。

3. 代码效率优化

   • 移除原代码中不必要的Activate和Select操作，直接通过对象引用操作单元格，大幅提升代码执行速度，尤其在拆分大量工作簿时效果明显。

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