Excel VBA多工作表按指定列拆分文件问题求助

嘿，一眼就瞅到问题所在了！你在处理第二个工作表Service_Level_Detailed时，犯了个对象引用的错误：你之前定义的ws对象一直指向的是Customer_Level_Detailed工作表，但Query2是在Service_Level_Detailed表里的，用ws.ListObjects("Query2")自然会找不到对应的列表对象，直接报错。

修正后的完整代码 #

Dim ArrayItem As Long
Dim wsCust As Worksheet ' 第一个工作表对象
Dim wsService As Worksheet ' 第二个工作表对象
Dim ArrayOfUniqueValues As Variant
Dim SavePath As String
Dim ColumnHeadingInt As Long
Dim ColumnHeadingStr As String
Dim rng As Range
Dim MainWkbk As Workbook
Dim NextWkbk As Workbook
Dim CustomerLevelRange As Range
Dim tbl As ListObject
Dim Pt As PivotTable
Dim CurrentFilter

Set MainWkbk = ActiveWorkbook
Set wsCust = Sheets("Customer_Level_Detailed")
Set wsService = Sheets("Service_Level_Detailed") ' 新增第二个工作表对象
SavePath = "D:\test\"

' 获取第一个表的筛选列索引
ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, wsCust.Range("Query1[#Headers]"), 0)
ColumnHeadingStr = "Query1[[#All],[" & Range("ExportCriteria").Value & "]]"

Application.ScreenUpdating = False

' 提取唯一值
wsCust.Range(ColumnHeadingStr).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=wsCust.Range("UniqueValues"), Unique:=True
wsCust.Range("UniqueValues").EntireColumn.Sort Key1:=wsCust.Range("UniqueValues").Offset(1, 0), _
    Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(wsCust.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))
wsCust.Range("UniqueValues").EntireColumn.Clear

' 循环处理每个唯一值
For ArrayItem = 2 To UBound(ArrayOfUniqueValues)
    Workbooks.Add
    Set NextWkbk = ActiveWorkbook
    ActiveSheet.Name = "Customer_Level_Detailed"
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Service_Level_Detailed"
    
    ' --- 处理第一个工作表数据 ---
    MainWkbk.Activate
    wsCust.ListObjects("Query1").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
    wsCust.Range("Query1[#All]").SpecialCells(xlCellTypeVisible).Copy
    
    NextWkbk.Activate
    Sheets("Customer_Level_Detailed").Select
    Range("A3").PasteSpecial xlPasteAll
    Set CustomerLevelRange = Range(Range("A3"), Range("A3").SpecialCells(xlLastCell))
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, CustomerLevelRange, , xlYes)
    tbl.TableStyle = "TableStyleMedium15"
    
    ' --- 处理第二个工作表数据 ---
    MainWkbk.Activate
    ' 重新获取第二个表的筛选列索引（基于wsService的表头）
    ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, wsService.Range("Query2[#Headers]"), 0)
    ' 用wsService操作Query2，而不是原来的ws
    wsService.ListObjects("Query2").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
    wsService.Range("Query2[#All]").SpecialCells(xlCellTypeVisible).Copy
    
    NextWkbk.Activate
    Sheets("Service_Level_Detailed").Select
    Range("A3").PasteSpecial xlPasteAll
    ' 同样给第二个表创建列表样式（可选，和第一个表保持一致）
    Set CustomerLevelRange = Range(Range("A3"), Range("A3").SpecialCells(xlLastCell))
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, CustomerLevelRange, , xlYes)
    tbl.TableStyle = "TableStyleMedium15"
    
    ' 保存新工作簿（你之前的代码漏了这一步！）
    NextWkbk.SaveAs Filename:=SavePath & ArrayOfUniqueValues(ArrayItem) & ".xlsx"
    NextWkbk.Close SaveChanges:=False
Next ArrayItem

' 清除筛选
wsCust.AutoFilterMode = False
wsService.AutoFilterMode = False

MsgBox "Finished exporting!"
Application.ScreenUpdating = True

关键修改点说明 #

• 新增工作表对象：给Service_Level_Detailed单独定义了wsService变量，彻底区分两个不同的工作表，避免对象引用混淆。
• 修正筛选列索引获取：处理第二个表时，基于wsService的表头来匹配ExportCriteria的值，确保列索引正确。
• 修正列表对象调用：用wsService.ListObjects("Query2")来操作第二个表的自动筛选，而不是错误地使用原来的ws对象。
• 补充保存逻辑：原来的代码没有保存新建的工作簿，我补上了SaveAs和Close步骤，不然拆分后的文件只会在内存里，关闭Excel就没了。

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