Excel怎样快速将一张表按条件分为多张表

Excel怎样快速将一张表按条件分为多张表

前言

本篇主要记录如何将一张大数据量的表格按照某一列分割成多个xlsx单表文件的方法。提供了两种方法，两种方法视要求使用。1

按数据透视图拆分

按某一列拆分多表

首先点击 插入——数据透视表

选择新工作表或在当前工作表中选择一片区域，建议选择新工作表。

将用作筛选的拖入筛选框，其它拖入行框

选择 设计——分类汇总下拉——不显示分类汇总

选择 总计下拉——对行和列禁用

选择 报表布局下拉——以表格形式显示

选择 数据透视表分析——选项下拉——显示报表筛选页

点击确定等待一会，就可以看到自动生成出按筛选条件的各个工作表。

由工作表生成文件

选择 开发工具——Visual Basic（或直接ALT+F11），弹出VBA界面，随便选个工作表右键，选择插入——模块

复制以下代码进入代码框（自己改下路径，别傻乎乎复制 🤪）

Sub SplitEachWorksheet()

Dim FPath As String

'这是当前文件路径

FPath = Application.ActiveWorkbook.Path

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each ws In ThisWorkbook.Sheets

ws.Copy

' 改存储路径在这里

Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"

Application.ActiveWorkbook.Close False

Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

点这个执行就好了

按原表格式拆分代码

Sub 工作表按列拆分为工作簿()

'当前工作表（worksheet）按固定某列的值拆分为多个工作簿（workbook），文件单独保存

Dim arr, dict As Object

Set dict = CreateObject("scripting.dictionary"): tm = Timer

Set fso = CreateObject("Scripting.FileSystemObject")

'--------------------参数填写：num_col，数字，A列为1向右递增；title_row，数字，第1行为1向下递增

num_col = 4 '关键值列，按该列的值进行拆分，相同的保存在同一ws

title_row = 1 '表头行，每个拆分后的sheet都保留

Set ws = Application.ActiveSheet

wb_path = Application.ActiveWorkbook.Path '当前工作簿文件路径

wb_name = Application.ActiveWorkbook.Name '当前工作簿文件名和扩展名

save_path = wb_path + "\拆分表" '保存拆分后的表格保存路径

If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹

Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行

Application.DisplayAlerts = False '不显示警告信息

arr = ActiveSheet.UsedRange '所有数据行读取为数组，也可arr = [a1].CurrentRegion

For i = title_row + 1 To UBound(arr): '遍历关键值列，写入字典，key为关键值，item为对应的行

If Not dict.Exists(arr(i, num_col)) Then '新键-值

Set dict(arr(i, num_col)) = Rows(i)

Else '已有键-值，更新

Set dict(arr(i, num_col)) = Union(dict(arr(i, num_col)), Rows(i))

End If

Next

k = dict.Keys:v = dict.Items

For i = 0 To dict.count - 1: '遍历字典，创建、写入wb

Workbooks.Add

With ActiveSheet

ws.Rows(1).Copy

.[a1].PasteSpecial Paste:=xlPasteColumnWidths '复制列宽

ws.Rows(1 & ":" & title_row).Copy .[a1] '复制表头

v(i).Copy .Range("A" & title_row + 1) '复制数据

End With

'保存文件全名（文件路径、文件名、扩展名），keys命名

save_file = save_path & "\" & fso.GetBaseName(wb_name) & "_拆分表_" & k(i) & "." & fso.GetExtensionName(wb_name)

ActiveWorkbook.SaveAs filename:=save_file

ActiveWorkbook.Close (False)

'Exit For '强制退出for循环，单次测试使用

Next

Set fso = Nothing '释放内存

Application.ScreenUpdating = True

Application.DisplayAlerts = True

Debug.Print "工作表已拆分完成，累计用时" & Format(Timer - tm, "0.00") '耗时

End Sub