Excel中用VBA将根据列内容分割成多个工作表

Sub 工作表拆分2() '通过筛选方法完成需求，速度快，但当有合并单元格时就不能用。读者可以根据实际情况选用
Dim SplitCol As String, ColNum As Integer, HeadRows As Byte, arr, lastrow, i, ShtIndex, only As New Collection, Rng As Range
SplitCol = "c"  '指定拆分条件所在列
HeadRows = 2   '指定标题行数，该区域不参与拆分
If HeadRows >= ActiveSheet.UsedRange.Rows.Count Then Exit Sub '如果指定的标题行大于已用区域行数则退出程序
ColNum = Cells(1, SplitCol).Column  '将列标转换成数字
lastrow = ActiveSheet.UsedRange.Rows.Count  '获取当前表已用区域的行数
arr = Range(Cells(HeadRows + 1, SplitCol), Cells(lastrow, SplitCol)).Value  '将拆分列的数据赋与变量arr
On Error Resume Next
If ActiveSheet.FilterMode Then Cells.AutoFilter    '如果处于筛选模式，那么去除筛选模式
For i = 1 To lastrow - HeadRows  '遍历arr所有数据
'提取其中的不重复值
If Len(arr(i, 1)) > 0 Then only.Add CStr(arr(i, 1)), CStr(arr(i, 1))
Next i
ShtIndex = ActiveSheet.Index  '获取当前表位置
On Error Resume Next
For i = 1 To only.Count
Debug.Print Sheets(only(i)).Name  '获取与only对象中每个元素同名的工作表名（用意为判断是否存在该工作表）
If Err = 0 Then MsgBox "当前工作簿已存在与待拆分项目同名的工作表“" & only(i) & "”，暂无法拆分", 64, "友情提示": Exit Sub
Err.Clear
Next i
Application.ScreenUpdating = False  '关闭屏幕更新，加快执行速度
Application.Calculation = xlCalculationManual  '调为手动计算，加快执行速度
For i = 1 To only.Count  '创建工作表，表的数量与表名由only对象中不重复值而定
Sheets.Add After:=Sheets(Sheets.Count)  '创建
Sheets(Sheets.Count).Name = only(i)    '命名
Sheets(ShtIndex).Rows("1:" & HeadRows).Copy Sheets(Sheets.Count).Cells(1, 1)  '复制标题
Next i
Sheets(ShtIndex).Select   '返回待拆分工作表
For i = 1 To only.Count '遍历Collection对象所有成员。Collection对象包括了所有拆分条件，即工作表名
'对拆分条件所在列进行筛选，筛选条件是Collection对象中的成员，本例中是部门名称
Range(Cells(HeadRows, SplitCol), Cells(lastrow, SplitCol)).AutoFilter Field:=1, Criteria1:=only(i)
Set Rng = Range(Cells(HeadRows + 1, SplitCol), Cells(Rows.Count, SplitCol).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow '引用筛选后的数据（整行）
With Sheets(only(i)).UsedRange.Rows(Sheets(only(i)).UsedRange.Rows.Count + 1) '引用拆分后的工作表的已用区域下一行
Rng.Copy .Cells(1)  '第一次复制，复制所有数据，仅取其格式
.Cells = Rng.Value  '第二次复制，仅复制数值
End With
Next
Cells.AutoFilter '去除筛选模式
Application.ScreenUpdating = True  '恢复屏幕更新
Application.Calculation = xlCalculationAutomatic  '恢复自动计算
MsgBox "拆分完毕！", 64, "友情提示"
End Sub