EXCEL拆分数据(表、文件)

Sub SplitTheSht() '逐行复制，速度偏慢，通用性好 按某列拆分成多个sheet表
Dim SplitCol As Integer, ColNum As Integer, HeadRows As Byte, arr, lastrow, i, ShtIndex, only As New Collection
SplitCol = 13 '指定拆分条件所在列。可以根据实际情况修改列标
HeadRows = 1 '指定标题行数，该区域不参与拆分
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
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 = HeadRows + 1 To lastrow '逐行复制数据
If Len(Cells(i, SplitCol)) > 0 Then '排除空值
With Sheets(Cells(i, SplitCol).Text).UsedRange.Rows(Sheets(Cells(i, SplitCol).Text).UsedRange.Rows.Count + 1)
Rows(i).Copy .Cells(1) '第一次复制，复制所有数据，仅取其格式
.Cells = Rows(i & ":" & i).Value '第二次复制，仅复制数值
End With
End If
Next i
Application.ScreenUpdating = True '恢复屏幕更新
Application.Calculation = xlCalculationAutomatic '恢复自动计算
MsgBox "拆分完毕", 64, "友情提示"
End Sub

Sub ShtToWorkbook() '将sheet表拆分成单个文件
Dim sht As Worksheet
Application.ScreenUpdating = False
    For Each sht In ThisWorkbook.Sheets
        sht.Copy
        With ActiveWorkbook
        Columns("J:J").Delete '删除辅助列
        .SaveAs ThisWorkbook.Path & "\" & sht.Name, _
        FileFormat:=XlFileFormat.xlOpenXMLWorkbook
        .Close True
        End With
    Next
    Application.ScreenUpdating = True
    MsgBox "拆分完成"
End Sub