按首列DPK值拆分Excel表格为独立文件的VBA代码报错求助

需求说明 #

我有一个包含13列、2万余行的Excel表格，A列（DPK）为升序排列，该列约有700种不同值。需为每个DPK值生成独立的.xlsx文件，文件需包含2行表头、13列及对应DPK值的所有数据行，文件名以对应DPK值命名。参考修改的VBA代码触发“Subscript out of range”错误，寻求修复。

原代码 #

Sub Separate_book_to_sheets1()
    Dim sht As Worksheet
    Dim DPK_book As Workbook
    Dim DPK_info, DPK_value As Range
    Dim DPK As String
    Set sht = ActiveWorkbook.Sheets(ASCONS)
    Set DPK_info = sht.Range("A3:M347")
    sht.Range("A3:A347").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht.Range("A3:A347"), Unique:=True
    For Each DPK_value In sht.Range("A3:A347")
        DPK = DPK_value.Text
        Set DPK_book = Workbooks.Add
        ActiveWorkbook.SaveAs Filename:="E:\Mike\Work\eCLIPSE\X\Projects\D0077 NEL\-Working\AsCons\DPKs\" & DPK & ".xlsx"
        Application.DisplayAlerts = False
        sht.Activate
        sht.AutoFilterMode = False
        DPK_info.AutoFilter field:=2, Criteria1:=DPK
        DPK_info.Copy
        DPK_book.Activate
        ActiveSheet.Paste
        ActiveWorkbook.Close SaveChanges:=True
    Next DPK_value
End Sub

原代码核心错误 #

• 工作表引用错误：ActiveWorkbook.Sheets(ASCONS) 中ASCONS未加引号，VBA会将其视为变量而非工作表名称，导致找不到对应工作表，触发"Subscript out of range"错误。
• 硬编码数据范围：A3:M347仅覆盖几百行，无法适配2万行的实际数据，且后续循环范围错误。
• AdvancedFilter使用错误：将重复值提取到原数据范围，会覆盖原有数据；且未指定空白目标区域存储唯一DPK值。
• 过滤列索引错误：DPK在A列（第1列），但代码中用field:=2过滤B列，无法匹配目标数据。
• 未处理空白值：循环会遍历到空白单元格，导致生成无效文件名。
• 未包含指定表头：未复制要求的2行表头。

修复后的完整代码 #

Sub SplitDPKToFiles()
    Dim wsSource As Worksheet
    Dim wsTemp As Worksheet
    Dim rngData As Range
    Dim rngUniqueDPK As Range
    Dim cell As Range
    Dim savePath As String
    Dim newWB As Workbook
    Dim lastRow As Long
    
    ' 设置参数：指定源工作表名称
    Set wsSource = ThisWorkbook.Sheets("ASCONS")
    savePath = "E:\Mike\Work\eCLIPSE\X\Projects\D0077 NEL\-Working\AsCons\DPKs\"
    
    ' 确保保存路径存在，不存在则自动创建
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    ' 获取完整数据范围（适配2万行的动态范围）
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set rngData = wsSource.Range("A2:M" & lastRow)
    
    ' 添加临时工作表存储唯一DPK值，避免覆盖原数据
    Set wsTemp = ThisWorkbook.Sheets.Add
    wsSource.Range("A3:A" & lastRow).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=wsTemp.Range("A1"), Unique:=True
    Set rngUniqueDPK = wsTemp.Range("A1:A" & wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp).Row)
    
    ' 关闭屏幕更新和警告弹窗，提升大文件处理效率
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 遍历每个唯一DPK值生成文件
    For Each cell In rngUniqueDPK
        If cell.Value <> "" Then ' 跳过空白单元格
            ' 创建新工作簿
            Set newWB = Workbooks.Add
            ' 复制2行表头到新工作簿
            wsSource.Range("A1:M2").Copy newWB.Sheets(1).Range("A1")
            ' 过滤当前DPK对应的数据（A列为第1列）
            rngData.AutoFilter Field:=1, Criteria1:=cell.Value
            ' 复制过滤后的数据到新工作簿（从第3行开始，避开已复制的表头）
            rngData.SpecialCells(xlCellTypeVisible).Copy newWB.Sheets(1).Range("A3")
            ' 保存并关闭新工作簿
            newWB.SaveAs Filename:=savePath & cell.Value & ".xlsx"
            newWB.Close SaveChanges:=False
        End If
    Next cell
    
    ' 清理临时工作表，恢复Excel默认设置
    wsTemp.Delete
    wsSource.AutoFilterMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "拆分完成！", vbInformation
End Sub

关键修改说明 #

1. 修正工作表引用方式，用引号明确指定工作表名称。
2. 采用动态范围获取数据，适配2万行的实际数据量。
3. 使用临时工作表存储唯一DPK值，避免覆盖原数据，同时保证循环仅处理有效值。
4. 将过滤列改为A列（第1列），匹配DPK所在位置。
5. 新增表头复制逻辑，满足2行表头的要求。
6. 自动检查并创建保存路径，避免因路径不存在导致的保存失败。
7. 关闭屏幕更新和警告弹窗，提升大文件的处理速度。

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