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 = 5 ' 表头行号
    Set objWorksheet = ActiveSheet
    
    ' 移除原表的筛选（提前处理，避免循环中干扰）
    If objWorksheet.AutoFilterMode Then
        objWorksheet.Rows(H_ROW).AutoFilter
    End If
    
    With objWorksheet
        nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        nColCnt = .Cells(H_ROW, .Columns.Count).End(xlToLeft).Column
        Set objDic = CreateObject("Scripting.Dictionary")
        
        ' 遍历数据，按C列值分组存储行范围
        For nRow = H_ROW + 1 To nLastRow
            strColValue = Trim(.Range("C" & 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
        objSheet.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        objSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
        
        ' 复制分组数据：先复制公式和格式，再复制行高
        objDic(varColValue).Copy
        objSheet.Cells(H_ROW + 1, 1).PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
        ' 单独复制行高
        Dim rng As Range
        For Each rng In objDic(varColValue)
            objSheet.Rows(rng.Row - H_ROW).RowHeight = rng.RowHeight
        Next rng
        
        ' 设置单元格锁定和保护
        objSheet.Cells.Locked = True
        objSheet.Range("Z:Z,AF:AF").Locked = False
        objSheet.Protect Password:="password", AllowFiltering:=True
        
        ' 保存并关闭工作簿
        savePath = "file path" ' 替换为实际保存路径
        objExcelWorkbook.SaveAs savePath & varColValue & ".xlsx"
        objExcelWorkbook.Close SaveChanges:=False
    Next
End Sub

修改说明 #

1. 提前处理筛选：在遍历数据前移除原工作表的筛选，避免循环中误操作新工作簿。
2. 优化表头复制：使用xlPasteAllUsingSourceTheme完整复制表头的公式、格式、隐藏列等属性，再单独粘贴列宽，确保表头属性完整保留。
3. 数据复制逻辑调整：先复制数据的公式和格式，再单独遍历设置行高，避免直接复制整行导致的公式丢失问题。
4. 修复工作表引用：所有操作明确指定原工作表或新工作表，避免激活状态变化导致的错误。

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