添加顶部分类汇总后，拆分工作表至多工作簿保留顶行报错求助

原代码失效的核心问题包括：分类汇总顶部行未被完整复制、循环逻辑错误导致行匹配失效、工作表命名未处理非法字符、工作簿保存逻辑位置错误，以及冗余的字典重复填充操作。以下是修复后的代码及关键说明：

修复后的VBA代码 #

Sub SplitSheetIntoMultipleWorkbooksWithHeaderRows()
    Dim objWorksheet As Worksheet
    Dim nLastRow As Long, nRow As Long, nNextRow As Long
    Dim strColumnValue As String
    Dim objDictionary As Object
    Dim varColumnValues As Variant
    Dim varColumnValue As Variant
    Dim objExcelWorkbook As Workbook
    Dim objSheet As Worksheet
    Dim savePath As String
    Dim headerRowsToKeep As Long ' 定义要保留的顶部行数
    
    ' 配置参数
    headerRowsToKeep = 8 ' 根据你的顶部行数量调整
    savePath = "C:\Your\Save\Path\" ' 替换为实际保存路径，注意末尾加反斜杠
    
    ' 检查保存路径是否存在，不存在则创建
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
    
    ' 构建唯一值字典（仅执行一次）
    Set objDictionary = CreateObject("Scripting.Dictionary")
    For nRow = headerRowsToKeep + 1 To nLastRow ' 从数据行开始遍历
        strColumnValue = CStr(objWorksheet.Range("A" & nRow).Value)
        If Not objDictionary.Exists(strColumnValue) Then
            objDictionary.Add strColumnValue, 1
        End If
    Next nRow
    
    varColumnValues = objDictionary.Keys
    
    ' 遍历每个唯一值，创建对应工作簿
    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
        
        ' 创建新工作簿
        Set objExcelWorkbook = Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        
        ' 处理工作表命名的非法字符
        Dim validSheetName As String
        validSheetName = Replace(varColumnValue, "/", "-")
        validSheetName = Replace(validSheetName, "\", "-")
        validSheetName = Replace(validSheetName, ":", "-")
        validSheetName = Replace(validSheetName, "*", "-")
        validSheetName = Replace(validSheetName, "?", "-")
        validSheetName = Replace(validSheetName, """", "-")
        validSheetName = Replace(validSheetName, "<", "-")
        validSheetName = Replace(validSheetName, ">", "-")
        validSheetName = Replace(validSheetName, "|", "-")
        validSheetName = Left(validSheetName, 31) ' 工作表名最多31个字符
        objSheet.Name = validSheetName
        
        ' 复制顶部行到新工作表
        objWorksheet.Rows("1:" & headerRowsToKeep).Copy Destination:=objSheet.Range("A1")
        
        ' 复制匹配当前值的数据行
        nNextRow = headerRowsToKeep + 1 ' 数据从顶部行下一行开始
        For nRow = headerRowsToKeep + 1 To nLastRow
            strColumnValue = CStr(objWorksheet.Range("A" & nRow).Value)
            If strColumnValue = CStr(varColumnValue) Then
                objWorksheet.Rows(nRow).Copy Destination:=objSheet.Range("A" & nNextRow)
                nNextRow = nNextRow + 1
            End If
        Next nRow
        
        ' 自动调整列宽
        objSheet.Columns("A:AF").AutoFit
        
        ' 保存并关闭工作簿
        objExcelWorkbook.SaveAs savePath & validSheetName & ".xlsx"
        objExcelWorkbook.Close SaveChanges:=False
    Next i
    
    Set objDictionary = Nothing
    Set objWorksheet = Nothing
    Set objSheet = Nothing
    Set objExcelWorkbook = Nothing
    
    MsgBox "拆分完成！", vbInformation
End Sub

关键修复点说明 #

• 顶部行完整保留：通过headerRowsToKeep变量指定要保留的顶部行数，一次性复制所有顶部行到新工作簿。
• 修复字典构建逻辑：仅从数据行（顶部行之后）遍历构建唯一值字典，避免重复填充。
• 合法工作表命名：替换所有Excel不允许的工作表名字符（如/:*?"<>|），并限制长度不超过31字符，解决命名报错问题。
• 修正循环与保存逻辑：将工作簿保存操作放到循环内部，确保每个唯一值对应的工作簿都被保存；移除冗余的二次字典填充循环，修复行匹配逻辑错误。
• 优化操作效率：移除Activate和Select操作，直接使用Copy Destination方式复制，提升代码稳定性与速度。
• 路径检查：自动创建不存在的保存路径，避免保存报错。

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