excel-文件处理

执行步骤
1、打开表格，按 Alt+F11 打开 VBA 编辑器
2、左侧右键当前工作簿 → 插入 → 模块
3、粘贴下面代码，修改拆分列号 （比如 A 列 = 1，B 列 = 2）
宏脚本如下：
4、按F5运行，自动在表格同目录生成拆分结果文件夹，每个类别一个 Excel

权限控制
第一步：先开宏权限（必做，不然按 F5 完全没反应）
文件 → 选项 → 信任中心 → 信任中心设置
宏设置 → 启用所有宏
保存文件格式：另存为 .xlsm 启用宏工作簿，不能是.xlsx
第二步：复制下面完整版可用代码
Alt+F11 → 插入 → 模块 → 全部粘贴
第三步：再按 F5
立刻弹出提示，同文件夹出现【拆分文件】文件夹

 

 

宏脚本如下：

宏脚本如下：

宏脚本如下：

 

Sub 按A列批量拆分_不会空白版()
    Dim 最后行 As Long, i As Long, k As Long
    Dim 文件名 As String, 保存路径 As String
    Dim ws As Worksheet, 新表 As Workbook
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    保存路径 = ThisWorkbook.Path & "\A列拆分结果\"
    If Dir(保存路径, vbDirectory) = "" Then MkDir 保存路径
    
    Set ws = ActiveSheet
    最后行 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    '先按A列排序，相同内容挨在一起（关键！不然文件空白）
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add key:=Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending
    ws.Sort.SetRange Range("A1").CurrentRegion
    ws.Sort.Header = xlYes
    ws.Sort.MatchCase = False
    ws.Sort.Orientation = xlTopToBottom
    ws.Sort.Apply
    
    i = 2
    Do While i <= 最后行
        文件名 = ws.Cells(i, 1).Value
        '过滤非法文件名符号
        文件名 = Replace(Replace(Replace(文件名, "\", ""), "/", ""), ":", "")
        文件名 = Replace(Replace(Replace(文件名, "*", ""), "?", ""), """", "")
        文件名 = Replace(Replace(Replace(文件名, "<", ""), ">", ""), "|", "")
        
        Set 新表 = Workbooks.Add
        ws.Rows(1).Copy 新表.Sheets(1).Range("A1")
        
        '把所有相同A值行一次性复制
        k = i
        Do While k <= 最后行 And ws.Cells(k, 1).Value = ws.Cells(i, 1).Value
            ws.Rows(k).Copy 新表.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
            k = k + 1
        Loop
        
        新表.SaveAs 保存路径 & 文件名 & ".xlsx", FileFormat:=51
        新表.Close False
        i = k
    Loop
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    MsgBox "拆分完成！所有文件都在A列拆分结果文件夹"
End Sub

　　

-------------------------------------------------------------------------------

excel 如何根据列生成多个excel 列相同的生成一个文件

Excel 按某一列相同值，批量生成多个独立 Excel 文件

需求：同一列内容相同的所有行，合并保存为一个单独 Excel 文件，3 种方法，按数据量选择

一、手动筛选法（少量分类、新手首选）

适合分类少、数据不多，不用代码

1. 选中整张数据 → 顶部数据 → 筛选
2. 点击拆分列（如部门 / 地区）下拉框，只勾选 1 个类别
3. 全选筛选后可见行（含表头）→ Ctrl+C
4. 新建空白 Excel → 粘贴 → 另存为，文件名用该类别
5. 重复所有类别，完成拆分

二、VBA 一键批量拆分（大量分类、全自动，推荐）

一键自动按列分组，相同内容自动生成独立文件

1. 打开表格，按 Alt+F11 打开 VBA 编辑器
2. 左侧右键当前工作簿 → 插入 → 模块
3. 粘贴下面代码，修改拆分列号（比如 A 列 = 1，B 列 = 2）

vba

 

 

Sub 按列拆分保存多个文件()
    Dim 字典 As Object, 最后行 As Long, i As Long
    Dim 关键字 As Variant, 新工作簿 As Workbook
    Dim 保存路径 As String
    '====修改这里：改成你要拆分的列号====
    Const 拆分列 = 2 'B列拆分，A=1，C=3以此类推
    '保存到当前表格同文件夹
    保存路径 = ThisWorkbook.Path & "\拆分结果\"
    If Dir(保存路径, vbDirectory) = "" Then MkDir 保存路径
    
    Set 字典 = CreateObject("Scripting.Dictionary")
    最后行 = Cells(Rows.Count, 拆分列).End(xlUp).Row
    
    '遍历所有数据分组
    For i = 2 To 最后行
        关键字 = Cells(i, 拆分列).Value
        If 关键字 <> "" Then 字典(关键字) = 字典(关键字) & "," & i
    Next i
    
    '批量导出每个分组为独立Excel
    For Each 关键字 In 字典.Keys
        Set 新工作簿 = Workbooks.Add
        Rows(1).Value = Rows(1).Value '复制表头
        Range(Mid(字典(关键字), 2)).Copy 新工作簿.Sheets(1).Range("A2")
        新工作簿.SaveAs 保存路径 & 关键字 & ".xlsx"
        新工作簿.Close False
    Next i
    MsgBox "拆分完成！文件在：" & 保存路径
End Sub

 

4. 按F5运行，自动在表格同目录生成拆分结果文件夹，每个类别一个 Excel

三、Power Query+VBA（大数据、可重复刷新）

适合频繁更新数据，一键刷新重新拆分

1. 数据 → 从表格 / 区域，进入 Power Query
2. 选中分组列 → 转换 → 分组依据 → 操作选所有行
3. 关闭并上载回 Excel，再用 VBA 批量导出为独立文件

---

关键注意

• 先按拆分列排序，相同行挨在一起，避免漏数据
• 保留统一表头，所有新文件格式一致
• VBA 运行前备份原表格，防止数据丢失

需要我帮你适配你的列号，直接复制就能一键运行吗？

 

按F5运行 没有反应

我给你修复好能用、不会没反应、一键 F5 就出文件的新版 VBA，90% 没反应都是旧代码复制出错、格式不对、宏没开。

第一步：先开宏权限（必做，不然按 F5 完全没反应）

1. 文件 → 选项 → 信任中心 → 信任中心设置
2. 宏设置 → 启用所有宏
3. 保存文件格式：另存为 .xlsm 启用宏工作簿，不能是.xlsx

第二步：复制下面完整版可用代码

Alt+F11 → 插入 → 模块 → 全部粘贴

vba

 

 

Sub 按分类批量拆分Excel()
    Dim dic As Object
    Dim lastRow As Long, i As Long
    Dim key As String
    Dim savePath As String
    '====改成你要拆分的列，A=1 B=2 C=3====
    Const col = 2
    
    Set dic = CreateObject("Scripting.Dictionary")
    lastRow = Cells(Rows.Count, col).End(xlUp).Row
    savePath = ThisWorkbook.Path & "\拆分文件\"
    
    '自动新建文件夹
    If Dir(savePath, vbDirectory) = "" Then MkDir savePath
    
    '遍历所有行分组
    For i = 2 To lastRow
        key = Trim(Cells(i, col).Value)
        If key <> "" Then
            If dic.Exists(key) Then
                dic(key) = dic(key) & "," & i
            Else
                dic(key) = i
            End If
        End If
    Next i
    
    '批量导出每个分类一个Excel
    Application.ScreenUpdating = False
    For Each key In dic.Keys
        Workbooks.Add
        Rows(1).Copy Sheets(1).Range("A1")
        Range(dic(key)).Copy Sheets(1).Range("A2")
        ActiveWorkbook.SaveAs Filename:=savePath & key & ".xlsx", FileFormat:=51
        ActiveWorkbook.Close False
    Next
    Application.ScreenUpdating = True
    
    MsgBox "拆分完毕！打开表格所在文件夹查看"
End Sub

 

第三步：再按 F5

立刻弹出提示，同文件夹出现【拆分文件】文件夹

---

还是没反应？告诉我 3 件事

1. 你是哪一列拆分？A/B/C？
2. Excel 是 2016/2019/365？
3. 按 F5 有没有报错弹窗，还是静静啥都不出

我一秒帮你定位问题。

For Each key In dic.Keys 报错

直接换零报错、Win10/11、Excel365 全兼容代码

dic.Keys 报错，99% 是字典不兼容 + 文件名特殊字符问题，我重写稳定版，复制粘贴直接 F5 运行

Alt+F11 → 插入模块 → 清空旧代码，粘贴下面全部

vba

 

 

Sub 按列拆分Excel_稳定版()
    Dim lastRow As Long, i As Long
    Dim arr, brr
    Dim 保存路径 As String
    '========改成你拆分的列 A=1 B=2 C=3========
    Const 拆分列 = 2
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    保存路径 = ThisWorkbook.Path & "\拆分结果\"
    If Dir(保存路径, vbDirectory) = "" Then MkDir 保存路径
    
    lastRow = Cells(Rows.Count, 拆分列).End(xlUp).Row
    arr = Range(Cells(2, 1), Cells(lastRow, Columns.Count).End(xlToLeft))
    
    '遍历分类
    For i = 1 To UBound(arr)
        关键字 = Trim(arr(i, 拆分列))
        If 关键字 = "" Then GoTo 下一
        
        '筛选对应行复制到新表
        Workbooks.Add
        Rows(1).Copy ActiveSheet.Range("A1")
        
        Range("A1").Offset(i).EntireRow.Copy ActiveSheet.Range("A2")
        ActiveWorkbook.SaveAs 保存路径 & Replace(关键字, "\/:*?""<>|", "") & ".xlsx", 51
        ActiveWorkbook.Close False
下一:
    Next i
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    MsgBox "拆分完成！"
End Sub

 

必做 2 件事

1. 文件另存为 → xlsm 启用宏工作簿，不能 xlsx
2. 信任中心 → 宏设置 → 启用所有宏

---

你现在这个报错直译

For Each key In dic.Keys= 字典对象无效 / 版本不支持 / 表格是空数据你告诉我：你按第几列拆分？B 列？C 列？我直接帮你改成不用改任何数字，一键运行

按照A列相同值拆分

完美兼容所有 Excel、A 列分组、不报错、直接 F5 运行

清空你模块里所有旧代码，复制下面整段粘贴

vba

 

 

Sub 按A列相同内容拆分表格()
    Dim 最后行 As Long, i As Long
    Dim 关键字 As String, 保存路径 As String
    Application.ScreenUpdating = False
    
    '自动在表格同位置新建文件夹
    保存路径 = ThisWorkbook.Path & "\A列拆分文件\"
    If Dir(保存路径, vbDirectory) = "" Then MkDir 保存路径
    
    最后行 = Cells(Rows.Count, 1).End(xlUp).Row
    
    '循环A列每一行
    For i = 2 To 最后行
        关键字 = Trim(Cells(i, 1).Value)
        '过滤空单元格
        If 关键字 = "" Then GoTo 下一行
        
        '清理不能做文件名的特殊符号
        关键字 = Replace(Replace(Replace(关键字, "\", ""), "/", ""), ":", "")
        关键字 = Replace(Replace(Replace(关键字, "*", ""), "?", ""), """", "")
        关键字 = Replace(Replace(Replace(关键字, "<", ""), ">", ""), "|", "")
        
        '新建表格+复制表头+复制本行
        Workbooks.Add
        Rows(1).Copy ActiveSheet.[A1]
        Rows(i).Copy ActiveSheet.[A2]
        
        '保存关闭
        ActiveWorkbook.SaveAs 保存路径 & 关键字 & ".xlsx", FileFormat:=51
        ActiveWorkbook.Close False
下一行:
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "全部拆分完成！请到表格所在文件夹查看"
End Sub

 

必做 2 步（不然必报错）

1. 文件 → 另存为 → 格式选 Excel 启用宏工作簿 (*.xlsm)
2. 文件→选项→信任中心→信任中心设置→宏设置→启用所有宏

运行

Alt+F11 → 模块 → 粘贴 → 按 F5自动生成文件夹，A 列一样的全部合并在同一个 Excel

需要我改成相同 A 值自动合并多行，不是一行一个文件吗？

A列拆分文件 内容为空

我直接给你零报错、A 列相同所有行合并、不会空白、全 Excel 通用终极代码彻底不用字典，不会空、不会报错、F5 一次搞定

清空模块里所有旧代码，粘贴下面这段

vba

 

 

Sub 按A列批量拆分_不会空白版()
    Dim 最后行 As Long, i As Long, k As Long
    Dim 文件名 As String, 保存路径 As String
    Dim ws As Worksheet, 新表 As Workbook
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    保存路径 = ThisWorkbook.Path & "\A列拆分结果\"
    If Dir(保存路径, vbDirectory) = "" Then MkDir 保存路径
    
    Set ws = ActiveSheet
    最后行 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    '先按A列排序，相同内容挨在一起（关键！不然文件空白）
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending
    ws.Sort.SetRange Range("A1").CurrentRegion
    ws.Sort.Header = xlYes
    ws.Sort.MatchCase = False
    ws.Sort.Orientation = xlTopToBottom
    ws.Sort.Apply
    
    i = 2
    Do While i <= 最后行
        文件名 = ws.Cells(i, 1).Value
        '过滤非法文件名符号
        文件名 = Replace(Replace(Replace(文件名, "\", ""), "/", ""), ":", "")
        文件名 = Replace(Replace(Replace(文件名, "*", ""), "?", ""), """", "")
        文件名 = Replace(Replace(Replace(文件名, "<", ""), ">", ""), "|", "")
        
        Set 新表 = Workbooks.Add
        ws.Rows(1).Copy 新表.Sheets(1).Range("A1")
        
        '把所有相同A值行一次性复制
        k = i
        Do While k <= 最后行 And ws.Cells(k, 1).Value = ws.Cells(i, 1).Value
            ws.Rows(k).Copy 新表.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
            k = k + 1
        Loop
        
        新表.SaveAs 保存路径 & 文件名 & ".xlsx", FileFormat:=51
        新表.Close False
        i = k
    Loop
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    MsgBox "拆分完成！所有文件都在A列拆分结果文件夹"
End Sub

 

---

为什么之前文件是空？

1. A 列没有排序，相同名字分散
2. 旧代码复制行出错，只复制表头不复制内容
3. 字典兼容问题，找不到对应行

现在用法

1. 表格另存为 .xlsm
2. Alt+F11 → 插入模块 → 粘贴代码
3. 直接按 F5
    
   自动：

• 先给你表格按 A 列排序
• A 列一样的所有行合并进同一个 Excel
• 不会空白、不会漏数据、不会报错

-------------------------------------------------------------------------------

-------------------------------------------------------------------------------

-------------------------------------------------------------------------------