VBA按I列数据拆分工作簿并排除该列的代码修改求助

你的问题核心是原代码的uniqueValues函数没处理I列的#N/A错误值，直接读取错误值会触发类型不匹配。下面是修改后的完整代码，完全满足你的需求：

Sub SplitDataToNewWorkbooks()
    Dim wsSource As Worksheet
    Dim lastRow As Long
    Dim uniqueVals As Collection
    Dim cell As Range
    Dim val As Variant
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    Dim savePath As String
    
    ' 设置源工作表（默认当前活动表，可根据实际修改）
    Set wsSource = ActiveSheet
    savePath = ThisWorkbook.Path & "\" ' 保存路径为当前工作簿所在文件夹
    
    ' 初始化唯一值集合，跳过I列的#N/A错误值
    Set uniqueVals = New Collection
    On Error Resume Next ' 忽略重复值添加时的错误
    lastRow = wsSource.Cells(wsSource.Rows.Count, "I").End(xlUp).Row
    For Each cell In wsSource.Range("I16:I" & lastRow) ' 从第16行开始，1-15行为表头
        If Not IsError(cell.Value) Then ' 跳过错误值，避免类型不匹配
            uniqueVals.Add cell.Value, Key:=CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0 ' 恢复正常错误处理
    
    ' 遍历每个唯一值，创建对应工作簿
    For Each val In uniqueVals
        ' 创建新工作簿
        Set wbNew = Workbooks.Add
        Set wsNew = wbNew.Sheets(1)
        
        ' 复制原表1-15行的A-H列完整表头
        wsSource.Range("A1:H15").Copy
        wsNew.Range("A1").PasteSpecial Paste:=xlPasteAll ' 保留表头格式和内容
        
        ' 筛选源表中I列等于当前值的行，复制A-H列数据
        wsSource.Range("A1:H" & lastRow).AutoFilter Field:=9, Criteria1:=val ' Field=9对应I列
        wsSource.Range("A16:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy
        wsNew.Range("A16").PasteSpecial Paste:=xlPasteValuesAndNumberFormats ' 仅复制值和格式
        wsSource.AutoFilterMode = False ' 取消筛选
        
        ' 处理文件名非法字符（避免保存失败）
        Dim fileName As String
        fileName = Replace(Replace(Replace(Replace(val, "/", "-"), "\", "-"), ":", "-"), "*", "-")
        fileName = Replace(Replace(Replace(fileName, "?", "-"), """", "-"), "<>", "-")
        
        ' 保存并关闭新工作簿
        wbNew.SaveAs Filename:=savePath & fileName & ".xlsx"
        wbNew.Close SaveChanges:=False
    Next val
    
    MsgBox "拆分完成！", vbInformation
End Sub

关键修改说明： #

• 错误值处理：遍历I列时用IsError(cell.Value)跳过#N/A，从根源避免类型不匹配
• 唯一值获取：用Collection存储唯一值，通过错误忽略机制自动去重，比原uniqueValues函数更稳定
• 表头复制：直接复制原表1-15行的A-H列，完整保留表头的格式和内容
• 工作簿拆分：每次循环创建新工作簿，筛选对应I列值的行后复制A-H列数据
• 文件名兼容：替换文件名中的非法字符（/、\、:等），确保能正常保存

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