Excel VBA按列值拆分数据至新工作簿时Advanced Filter报错求助

我需要将“Price Format”和“Rebates”两个工作表的数据，分别依据“Price Format”的B列、“Rebates”的D列列值导出到新工作簿。参考视频代码已成功实现“Price Format”工作表的导出，但编写“Rebates”的代码时，第二个Advanced Filter出现运行时错误'1004'，以下是我的VBA代码：

Sub Split_Data_in_workbooks()

Application.ScreenUpdating = False

Dim shD As Worksheet
Dim shT As Worksheet
Dim shR As Worksheet
Dim rngD As Range
Dim rngC As Range
Dim rngE As Range
Dim rngF As Range
Dim rFolder As String
Dim i As Integer
Dim wbR As Workbook
Dim shO As Worksheet
Dim shQ As Worksheet

Set shD = ThisWorkbook.Worksheets("Price Format")
Set shT = ThisWorkbook.Worksheets("Settings")
Set shR = ThisWorkbook.Worksheets("Rebates")

shD.Range("B:B").Copy shT.Range("A:A")
shR.Range("D:D").Copy shT.Range("B:B")
shT.Range("A:A").RemoveDuplicates 1, xlYes
shT.Range("B:B").RemoveDuplicates 1, xlYes
rFolder = ThisWorkbook.Path & "\\Output"

Set rngD = shD.Range("A1").CurrentRegion
Set rngC = shT.Range("D1:D2")
Set rngE = shR.Range("A1").CurrentRegion
Set rngF = shT.Range("B1:B2")

shT.Range("D1") = shT.Range("A1")

i = 2

While shT.Cells(i, 1) <> ""

shT.Range("D2") = shT.Cells(i, 1)

Set wbR = Workbooks.Add
Set shO = wbR.Worksheets(1)
Set shQ = wbR.Worksheets(2)

rngD.AdvancedFilter xlFilterCopy, rngC, shO.Range("A1")
rngE.AdvancedFilter xlFilterCopy, rngF, shQ.Range("A1")

shO.Columns.AutoFit
shO.Columns("A:C").Delete
shO.Name = shT.Cells(i, 1)
ActiveWindow.DisplayGridlines = False

shQ.Columns.AutoFit
shQ.Name = shT.Cells(i, 1)
ActiveWindow.DisplayGridlines = False

wbR.SaveAs rFolder & shT.Cells(i, 1) & ".xlsx"

i = i + 1

shT.Range("A:B").Clear

Wend

End Sub

错误原因分析 #

1. 条件区域表头不匹配：高级筛选要求条件区域的表头必须与数据源表头完全一致。当前代码中rngF指向的shT.Range("B1:B2")，B1是从Rebates表D列复制的第一个数据（而非表头），导致筛选时无法匹配数据源列。
2. 新建工作簿工作表数量错误：Workbooks.Add默认仅创建1个工作表，直接引用Worksheets(2)会触发下标越界错误，进而导致后续高级筛选失败。
3. 循环内错误清空关键数据：循环中执行shT.Range("A:B").Clear会删除去重后的唯一值列表，导致循环仅执行一次就终止。
4. 文件夹路径格式无效：路径中使用\\会导致路径错误，且未判断Output文件夹是否存在，可能引发保存失败。

修正后的代码 #

Sub Split_Data_in_workbooks()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False ' 关闭保存提示
    
    Dim shD As Worksheet, shT As Worksheet, shR As Worksheet
    Dim rngD As Range, rngC As Range, rngE As Range, rngF As Range
    Dim rFolder As String, uniqueVal As Variant
    Dim wbR As Workbook, shO As Worksheet, shQ As Worksheet
    Dim lastRowA As Long
    
    ' 初始化工作表对象
    Set shD = ThisWorkbook.Worksheets("Price Format")
    Set shT = ThisWorkbook.Worksheets("Settings")
    Set shR = ThisWorkbook.Worksheets("Rebates")
    
    ' 复制列数据并去重
    shD.Range("B:B").Copy shT.Range("A1")
    shR.Range("D:D").Copy shT.Range("B1")
    shT.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
    shT.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlYes
    
    ' 处理输出文件夹
    rFolder = ThisWorkbook.Path & "\Output\"
    If Dir(rFolder, vbDirectory) = "" Then MkDir rFolder ' 不存在则创建
    
    ' 定义数据源区域
    Set rngD = shD.Range("A1").CurrentRegion
    Set rngE = shR.Range("A1").CurrentRegion
    
    ' 设置筛选条件表头（与数据源列匹配）
    shT.Range("D1") = shD.Range("B1").Value
    shT.Range("E1") = shR.Range("D1").Value
    Set rngC = shT.Range("D1:D2")
    Set rngF = shT.Range("E1:E2")
    
    ' 获取去重后的最后一行
    lastRowA = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历每个唯一值
    For i = 2 To lastRowA
        uniqueVal = shT.Cells(i, "A").Value
        
        ' 设置筛选条件值
        shT.Range("D2") = uniqueVal
        shT.Range("E2") = uniqueVal ' 若两个表筛选值不对应，需调整此处逻辑
        
        ' 创建新工作簿并添加第二个工作表
        Set wbR = Workbooks.Add
        Set shO = wbR.Worksheets(1)
        wbR.Worksheets.Add After:=shO
        Set shQ = wbR.Worksheets(2)
        
        ' 执行高级筛选
        rngD.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngC, CopyToRange:=shO.Range("A1"), Unique:=False
        rngE.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngF, CopyToRange:=shQ.Range("A1"), Unique:=False
        
        ' 格式化工作表
        With shO
            .Columns.AutoFit
            .Columns("A:C").Delete ' 根据实际需求调整删除列
            .Name = uniqueVal
            .Parent.Windows(1).DisplayGridlines = False
        End With
        
        With shQ
            .Columns.AutoFit
            .Name = uniqueVal
            .Parent.Windows(1).DisplayGridlines = False
        End With
        
        ' 保存并关闭工作簿
        wbR.SaveAs Filename:=rFolder & uniqueVal & ".xlsx"
        wbR.Close SaveChanges:=False
    Next i
    
    ' 清理临时数据
    shT.Range("A:E").Clear
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "数据导出完成！"
End Sub

关键修正点 #

• 修正条件区域表头，确保与数据源列完全匹配；
• 手动添加第二个工作表，避免下标越界；
• 将临时数据清空操作移到循环结束后，保证唯一值列表完整；
• 修复文件夹路径并添加自动创建逻辑；
• 优化代码结构，添加提示关闭与格式化简化。

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