VBA筛选数据并保存新文件代码编译错误求助

错误原因分析 #

原代码中Resize行出现编译错误，核心原因是当dataRange仅包含表头（1行）时，dataRange.Rows.Count -1 = 0，Resize的行数参数为0不符合语法要求；同时循环中未取消上一次的筛选，容易引发筛选叠加的异常问题。

修复后的完整代码 #

Sub FilterAndSave()
    Dim filterRange As Range, dataRange As Range, filteredData As Range
    Dim lastRow As Long, i As Long
    Dim folderPath As String, fileName As String
    
    ' 设置筛选条件区域和数据区域
    Set filterRange = Sheet1.Range("A1:A8")
    Set dataRange = Sheet2.Range("A1").CurrentRegion
    
    ' 关闭提示和屏幕刷新，提升运行效率
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ' 遍历每个筛选条件
    For i = 1 To filterRange.Rows.Count
        ' 先取消上一次的筛选，避免筛选叠加
        dataRange.AutoFilter
        
        ' 设置当前筛选条件（第1列）
        dataRange.AutoFilter Field:=1, Criteria1:=filterRange.Cells(i, 1).Value
        
        ' 尝试获取可见数据（包含表头）
        On Error Resume Next
        Set filteredData = dataRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' 确认存在有效数据行（排除仅表头的情况）
        If Not filteredData Is Nothing And filteredData.Rows.Count > 1 Then
            ' 提取数据部分（排除表头）
            Set filteredData = filteredData.Offset(1, 0).Resize(filteredData.Rows.Count - 1)
            
            ' 创建保存文件夹（不存在则新建，使用当前工作簿的相对路径）
            folderPath = ThisWorkbook.Path & "\" & filterRange.Cells(i, 1).Value & "\"
            If Len(Dir(folderPath, vbDirectory)) = 0 Then
                MkDir folderPath
            End If
            
            ' 设置文件名
            fileName = filterRange.Cells(i, 1).Value & ".xlsx"
            
            ' 复制筛选后的数据并保存（包含表头）
            Workbooks.Add
            ' 复制表头到新文件
            dataRange.Rows(1).Copy Destination:=ActiveSheet.Range("A1")
            ' 复制筛选后的数据
            filteredData.Copy Destination:=ActiveSheet.Range("A2")
            ' 保存并关闭新文件
            ActiveWorkbook.SaveAs folderPath & fileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            ActiveWorkbook.Close False
            
            ' 删除已筛选的行（先取消筛选确保删除完整）
            dataRange.AutoFilter
            filteredData.EntireRow.Delete
        End If
    Next i
    
    ' 取消最后一次筛选
    dataRange.AutoFilter
    
    ' 恢复提示和屏幕刷新
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    ' 检查是否有未被筛选的剩余数据
    If WorksheetFunction.CountA(dataRange) > 1 Then
        MsgBox "存在未被筛选的剩余数据", vbExclamation
    End If
End Sub

关键修改点 #

• 修复编译错误：先获取包含表头的可见区域，再判断是否存在有效数据行，避免Resize参数为0的非法情况。
• 添加筛选重置：每次循环前取消上一次的筛选，防止筛选条件叠加导致的逻辑错误。
• 完善文件结构：新增复制表头到目标文件，确保保存的文件包含完整的列标题。
• 优化路径逻辑：使用ThisWorkbook.Path生成相对路径，避免因绝对路径导致的保存失败。
• 修正删除逻辑：删除已筛选行前先取消筛选，确保所有目标行被正确删除。

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