1、工作簿按具体字段拆分为工作簿
Sub 同步拆分()
MsgBox "开始运行"
Application.ScreenUpdating = False
'创建一个字典对象
Set d = CreateObject("Scripting.Dictionary")
'定义当前的工作簿
Set wb1 = ThisWorkbook
'遍历当前工作簿的所有sheet
Set group = Application.InputBox(prompt:="请输入需要拆分的字段为", Type:=8)
For Each Sht In Sheets
'获取当前sheet的所有动态区域
ara = Sht.[a1].CurrentRegion
'UBound该区域的列数，for 循环
'MsgBox UBound(ara, 2)
For i = 1 To UBound(ara, 2)
'取到第一行中的需要拆分的字段名，几张表就有几个J
If ara(1, i) = group Then j = i: Exit For
Next
'第几行开始计算，如果表头为2行，则为i=3
For i = 2 To UBound(ara)
d(ara(i, j)) = ""
Next
Next
k = d.keys: t = d.items
'字典里存了多少的key（多少关键字）来创建多少张表，为什么用这个字典是为了去重
For i = 0 To UBound(k)
Application.SheetsInNewWorkbook = wb1.Sheets.Count
Workbooks.Add
Set wb = ActiveWorkbook
With wb
'针对新建工作簿的每个sheet进行操作
For x = 1 To wb1.Sheets.Count
'取待拆分表的范围
ara = wb1.Sheets(x).[a1].CurrentRegion
'复制从第几行开始 m
m = 2
'找到需要拆分的列，并把列数赋值给jj
For j = 1 To UBound(ara, 2)
If ara(1, j) = group Then jj = j: Exit For
Next
'第几行开始计算，如果表头为2行，则为j=3
For j = 2 To UBound(ara)
'判断某个字段等于字典key，即把挨个片区的内容copy出来
If ara(j, jj) = k(i) Then
'拷贝数据至目标表的第2行开始依次拷贝
wb1.Sheets(x).Cells(j, 1).Resize(1, UBound(ara, 2)).Copy .Sheets(x).Cells(m, 1)
'拷贝表头
wb1.Sheets(x).Cells(1, 1).Resize(1, UBound(ara, 2)).Copy .Sheets(x).[a1]
m = m + 1
End If
Next
'命名sheetname
'MsgBox wb1.Sheets(x).Name
.Sheets(x).Name = wb1.Sheets(x).Name
'设置单位格线
.Sheets(x).[a2].CurrentRegion.Borders.LineStyle = 1
For y = 1 To UBound(ara, 2)
'设置列宽
.Sheets(x).Columns(y).ColumnWidth = wb1.Sheets(x).Columns(y).ColumnWidth
Next
Next
End With
'保存wb
wb.SaveAs ThisWorkbook.Path & "\" & Split(wb1.Name, ".")(0) & "(" & k(i) & ")" & ".xlsx"
wb.Close
Next
'输出OK
MsgBox "OK"
'这个是关闭屏幕刷新，在涉及多文件操作，打开关闭excel文件，或者激活工作表等操作的时候，可以加快代码运行速度 FLASE
Application.ScreenUpdating = True
End Sub
2、针对某工作表中的具体字段拆分工作表
Option Explicit
Option Base 1
Sub 按指定列分组拆分数据()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim self As Worksheet
Set self = ActiveSheet
Dim nLastRowNum As Long
Dim nLastColumnNum As Long
Dim i As Long
' 删除其他的sheet
For i = Sheets.Count To 1 Step -1
If Sheets(i).Name <> self.Name Then
Sheets(i).Delete
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'获取全部数据范围
nLastRowNum = Cells(Rows.Count, 1).End(xlUp).Row
nLastColumnNum = Cells(nLastRowNum, Columns.Count).End(xlToLeft).Column
'获取标题
Dim titleRange As Range
Set titleRange = Application.InputBox(prompt:="请选择标题区域：将要当做标题行的每一个单元格", Type:=8)
' 有效数据开始行
Dim nRowValidData As Long
nRowValidData = titleRange.Row + titleRange.Rows.Count
' 获取拆分列的信息,只需要列号
Dim splitColumnRange As Range
Set splitColumnRange = Application.InputBox(prompt:="请选择拆分的列：选择任何一个该列的单元格即可", Type:=8)
Dim columnNumToSplit As Long
columnNumToSplit = splitColumnRange.Column
' 需要拆分的值字典
Dim splitValueDict As Object
' 辅助字典用来保证顺序
Dim splitValueDictReverse As Object
Dim indexArray() As Long
Set splitValueDict = CreateObject("Scripting.Dictionary")
Set splitValueDictReverse = CreateObject("Scripting.Dictionary")
Dim cellValue As String
Dim ws As Worksheet
For i = nRowValidData To nLastRowNum Step 1
cellValue = Cells(i, columnNumToSplit).Text
'1. 创建新的sheet；
'2. 拷贝标题信息到新的sheet
If Not splitValueDict.Exists(cellValue) Then
splitValueDict(cellValue) = i
splitValueDictReverse(i) = cellValue
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = cellValue
self.Activate
titleRange.Copy _
ws.Range(ws.Cells(titleRange.Row, titleRange.Column), ws.Cells(nRowValidData - 1, titleRange.Column))
End If
' 拷贝其他内容
Range(Cells(i, 1), Cells(i, nLastColumnNum)).Copy _
GetLastPasteRangeBySheetName(cellValue, nLastColumnNum)
Next i
End Sub
Public Function GetLastPasteRangeBySheetName(ByRef SheetName As String, columnNum As Long) As Variant
Dim wks As Worksheet
Dim nLastRowNum As Long
Set wks = ActiveWorkbook.Worksheets(SheetName)
nLastRowNum = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
Set GetLastPasteRangeBySheetName = wks.Range(wks.Cells(nLastRowNum + 1, 1), wks.Cells(nLastRowNum + 1, columnNum))
End Function
3、各工作表按表名直接拆分为工作簿
Sub 拆分到工作簿()
Dim Sht As Worksheet, Wp As String, Wkb As Workbook
Application.DisplayAlerts = False
Set Wkb = ActiveWorkbook
Wp = Wkb.Path
For Each Sht In Wkb.Worksheets
Sht.Select
Sht.Copy
ActiveWorkbook.SaveAs Filename:=Wp & "\" & Sht.Name & ".xlsx", FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close 0
Next
Application.DisplayAlerts = True
End Sub
附如何在Excel中执行宏代码
打开Excel 后 文件选项卡--选项--加载项
1）先加载开发工具
2）在开发工具选项卡下点击查看代码
3）执行代码宏，完成拆分目标
