如何在Excel拆分工作簿宏中保留格式与锁定单元格？

原VBA代码拆分工作表后，无法保留行列尺寸、锁定单元格等格式，以下是修改后的代码，可完整保留这些格式：

Option Explicit

Sub SplitSheetIntoMultipleWorkbooksBasedOnColumn()
    Dim objWorksheet As Worksheet
    Dim nLastRow As Long, nRow As Long
    Dim nColCnt As Long, rowRng As Range
    Dim strColValue As String, savePath As String
    Dim objDic As Object, i As Long
    Dim varColValues As Variant
    Dim varColValue As Variant
    Dim objExcelWorkbook As Workbook
    Dim objSheet As Worksheet
    Const H_ROW = 8 ' 表头行号
    
    Set objWorksheet = ActiveSheet
    With objWorksheet
        nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        nColCnt = .Cells(H_ROW, .Columns.Count).End(xlToLeft).Column
        Set objDic = CreateObject("Scripting.Dictionary")
        
        ' 遍历数据，按B列值分组
        For nRow = H_ROW + 1 To nLastRow
            strColValue = Trim(.Range("B" & nRow).Value)
            If Len(strColValue) > 0 Then
                Set rowRng = .Cells(nRow, 1).Resize(1, nColCnt)
                If objDic.Exists(strColValue) Then
                    Set objDic(strColValue) = Union(rowRng, objDic(strColValue))
                Else
                    Set objDic(strColValue) = rowRng
                End If
            End If
        Next
    End With
    
    varColValues = objDic.Keys
    For i = LBound(varColValues) To UBound(varColValues)
        varColValue = varColValues(i)
        Set objExcelWorkbook = Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
        
        ' 复制表头及上方行，保留所有格式
        objWorksheet.Rows("1:" & H_ROW).Copy
        With objSheet.Range("A1")
            .PasteSpecial xlPasteAll ' 粘贴所有内容和格式
            .PasteSpecial xlPasteColumnWidths ' 单独粘贴列宽
        End With
        
        ' 复制分组数据，保留格式
        objDic(varColValue).Copy
        With objSheet.Cells(H_ROW + 1, 1)
            .PasteSpecial xlPasteAll
            .PasteSpecial xlPasteColumnWidths
        End With
        
        ' 同步行高
        Dim sourceRow As Range, targetRow As Range
        For Each sourceRow In objWorksheet.Rows("1:" & H_ROW)
            Set targetRow = objSheet.Rows(sourceRow.Row)
            targetRow.RowHeight = sourceRow.RowHeight
        Next
        For Each sourceRow In objDic(varColValue).EntireRow
            Set targetRow = objSheet.Rows(sourceRow.Row)
            targetRow.RowHeight = sourceRow.RowHeight
        Next
        
        ' 同步单元格锁定状态（如果原表有保护）
        objSheet.Cells.Locked = objWorksheet.Cells.Locked
        ' 若原工作表处于保护状态，可取消注释下面一行同步保护设置
        ' objSheet.Protect Password:=objWorksheet.ProtectContents, DrawingObjects:=objWorksheet.ProtectDrawingObjects, Contents:=objWorksheet.ProtectContents
        
        ' 保存工作簿
        savePath = "file path" ' 替换为实际保存路径
        objExcelWorkbook.SaveAs savePath & varColValue & ".xlsx"
        objExcelWorkbook.Close SaveChanges:=False
    Next
End Sub

关键修改说明 #

• 使用xlPasteAll粘贴所有内容和格式，包括单元格锁定属性
• 新增xlPasteColumnWidths确保列宽完全一致
• 单独遍历行，同步每行的行高（直接复制整行有时无法保留行高）
• 同步单元格的Locked属性，若原工作表有保护，可取消注释代码同步保护设置

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