VBA宏筛选导出功能异常求助：无法导出全部匹配行

问题分析 #

先拆解你遇到的两个核心问题：

1. 仅复制每个唯一值的第一行：原代码的粘贴逻辑有误，后续行覆盖了之前的内容；同时遍历整列时未限定有效数据范围，可能提前终止循环。
2. 空白值导出异常：原代码遇到空值直接退出循环，导致空白行未被处理；且未将空白值作为独立的唯一值进行导出，同时表头复制逻辑缺失。

修正后的完整代码 #

Sub ExportByUniqueValues()
    Dim hasHeader As Boolean
    Dim colLetter As String
    Dim wb As Workbook
    Dim d As Range
    Dim lastValue As Variant
    Dim savePath As String
    Dim wsSource As Worksheet
    Dim lastRow As Long
    Dim targetRow As Long
    
    ' 配置参数
    savePath = ThisWorkbook.Path ' 保存路径（与原文件同目录）
    hasHeader = True ' 是否有表头
    colLetter = "D" ' 目标列
    
    Set wsSource = ThisWorkbook.Worksheets(1)
    
    ' 取消现有筛选（避免排序出错）
    If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False
    
    ' 获取目标列的最后一行数据
    lastRow = wsSource.Cells(wsSource.Rows.Count, colLetter).End(xlUp).Row
    
    ' 对目标列排序，确保相同值连续
    With wsSource.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsSource.Range(colLetter & "1:" & colLetter & lastRow), _
                        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange wsSource.Range("A1:" & wsSource.Cells(lastRow, wsSource.Columns.Count).Address)
        .Header = IIf(hasHeader, xlYes, xlNo)
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' 初始化变量
    lastValue = ""
    targetRow = 1
    
    ' 遍历目标列的有效数据行
    For Each d In wsSource.Range(colLetter & IIf(hasHeader, 2, 1) & ":" & colLetter & lastRow)
        Dim currentValue As Variant
        currentValue = d.Value
        
        ' 处理新的唯一值（包括空白值）
        If currentValue <> lastValue Or (IsEmpty(currentValue) And lastValue <> "") Then
            ' 保存并关闭之前的工作簿
            If Not wb Is Nothing Then
                ' 处理空白值的文件名
                Dim fileName As String
                fileName = IIf(IsEmpty(lastValue), "空白值", lastValue)
                wb.SaveAs savePath & "\" & fileName & ".xlsx"
                wb.Close SaveChanges:=False
                Set wb = Nothing
            End If
            
            ' 创建新工作簿
            Set wb = Application.Workbooks.Add
            targetRow = 1
            
            ' 复制表头（如果有）
            If hasHeader Then
                wsSource.Rows(1).Copy wb.Sheets(1).Cells(targetRow, 1)
                targetRow = targetRow + 1
            End If
            
            ' 更新最后值
            lastValue = currentValue
        End If
        
        ' 复制当前行到新工作簿
        wsSource.Rows(d.Row).Copy wb.Sheets(1).Cells(targetRow, 1)
        targetRow = targetRow + 1
    Next d
    
    ' 处理最后一组数据（包括空白值）
    If Not wb Is Nothing Then
        Dim finalFileName As String
        finalFileName = IIf(IsEmpty(lastValue), "空白值", lastValue)
        wb.SaveAs savePath & "\" & finalFileName & ".xlsx"
        wb.Close SaveChanges:=False
        Set wb = Nothing
    End If
    
    MsgBox "导出完成！文件保存至：" & savePath, vbInformation
End Sub

关键修改点说明 #

针对问题1的修复：

• 限定有效数据范围：通过lastRow获取目标列的最后一行数据，避免遍历整列的空行，防止提前终止循环。
• 正确控制粘贴位置：使用targetRow变量跟踪新工作簿的当前行，每次复制后自动递增，避免覆盖之前的内容。
• 明确表头复制逻辑：新建工作簿时先复制表头（如果启用），确保每个导出文件都包含表头。

针对问题2的修复：

• 处理空白值：将空白值（IsEmpty(currentValue)）作为独立的唯一值处理，不再遇到空值就退出循环。
• 空白值文件名：为空白值导出的文件命名为“空白值”，避免文件名无效。
• 取消筛选再排序：运行宏前先清除现有筛选，确保排序能正确整理所有数据，包括空白行。
• 筛选状态兼容：无论原工作表是否处于筛选状态，宏都能正常处理所有数据（包括空白行）。

使用说明 #

1. 调整代码开头的配置参数（hasHeader、colLetter）匹配你的实际需求。
2. 确保原文件已保存（否则ThisWorkbook.Path会为空，导致保存失败）。
3. 运行宏后，所有唯一值（包括空白值）都会对应生成独立的Excel文件，保存至原文件同目录。

内容的提问来源于stack exchange，提问作者Not Quite A Statistician