Excel根据列筛选，筛选后根据筛选项拆分文件，文件按照筛选项命名【亲测】

excel根据列筛选，筛选后根据筛选项拆分文件，文件按照筛选项命名。
Sub SplitDataByColumn()
    Dim ws As Worksheet
    Dim dict As Object
    Dim cell As Range
    Dim key As Variant
    Dim savePath As String
    Dim col As Long
    Dim lastRow As Long
    
    ' 设置参数
    Set ws = ActiveSheet
    col = 19 ' 筛选列（C列）
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 选择保存位置
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "C:\Users\NET 3\Desktop\52310112MJ51382518001\"
        If .Show <> -1 Then Exit Sub
        savePath = .SelectedItems(1) & "\"
    End With
    
    ' 收集唯一值
    lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
    For Each cell In ws.Range(ws.Cells(2, col), ws.Cells(lastRow, col))
        If cell.Value <> "" Then dict(cell.Value) = 1
    Next
    
    ' 准备数据区域
    Dim dataRange As Range
    Set dataRange = ws.UsedRange
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 循环处理每个分类
    For Each key In dict.Keys
        dataRange.AutoFilter Field:=col, Criteria1:=key
        
        ' 检查可见行
        On Error Resume Next
        Dim visibleRows As Range
        Set visibleRows = dataRange.Offset(1).Resize(dataRange.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not visibleRows Is Nothing Then
            ' 创建新工作簿
            Dim newBook As Workbook
            Set newBook = Workbooks.Add
            
            ' 复制数据
            dataRange.Rows(1).Copy newBook.Sheets(1).Range("A1")
            visibleRows.Copy newBook.Sheets(1).Range("A2")
            
            ' 保存文件
            Dim fileName As String
            fileName = CleanName(CStr(key)) & ".xlsx"
            newBook.SaveAs savePath & fileName
            newBook.Close
        End If
    Next key
    
    ' 清理环境
    ws.AutoFilterMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "成功生成 " & dict.Count & " 个文件！"
End Sub

Function CleanName(str As String) As String
    ' 清理非法字符
    Dim chars As String: chars = "\/:*?""<>|"
    For i = 1 To Len(chars)
        str = Replace(str, Mid(chars, i, 1), "_")
    Next
    CleanName = str
End Function

使用说明：

1. 按 Alt+F11 打开VBA编辑器

2. 在左侧项目窗口中右键插入新模块

3. 粘贴上述代码

4. 修改 col 变量值为需要筛选的列号（例如3对应C列）

5. 返回Excel，按 Alt+F8 运行宏

功能特点：

• 自动识别数据范围

• 弹出文件夹选择对话框

• 自动处理特殊字符文件名

• 保留原始数据格式

• 生成标准XLSX格式文件

注意事项：

1. 确保首行为标题行

2. 数据区域需连续无空白

3. 文件保存时会自动覆盖同名文件

4. 建议先备份原始数据

此解决方案适用于需要定期拆分数据的场景，如客户分类、地区划分、产品类别等数据整理工作。通过修改列号参数，可快速适应不同数据结构的Excel文件。