Sub 将表按列拆分成多表并另存()
Dim sht, sht0, sht1 As Worksheet
Dim Msg, j, k, L, n As Integer '定义整形变量
Dim iRow, iColumn As Integer '定义存放行和列的数量
Dim BiaoMing, ShaiXuan, objFD As String
Dim sCol
Set sht0 = ActiveSheet
iRow = sht0.Range("a65536").End(xlUp).Row '获取行数
iColumn = sht0.Range("XFD1").End(xlToLeft).Column '获取列数
'询问用户是否确认进行操作
Msg = MsgBox("除了当前选中的表，其它表都将被删除，请确定是否继续", 17, "<<<<只剩选中表确认>>>>")
'MsgBox msg
If Msg = 2 Then
Exit Sub
End If
'删除激活表以外的表
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
For Each sht1 In Sheets
If sht1.Name <> sht0.Name Then
sht1.Delete
End If
Next
End If
Application.DisplayAlerts = True
'通过自定义函数获取用户选择的列
Msg = "请问您要按那列拆分表？" & Chr(13) & "可以输入A～XFD 或者 直接输入数字"
Tit = "表格列选择"
Typ = 1 + 2 '0=公式，1=数字，2=文本，4=逻辑值，8=单元格引用，16=错误值，64=数值数组
L = Get_Column_Num(Msg, Tit, Typ) '调用自定义函数转换后的列数
'拆分表
For j = 2 To iRow
n = 0
If sht0.Cells(j, L) = "" Then
BiaoMing = "空白"
Else
BiaoMing = sht0.Cells(j, L)
End If
For Each sht In Sheets
If sht.Name = BiaoMing Then
n = 1
End If
Next
If n = 0 Then
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = BiaoMing
End If
Next
'拷贝数据
For k = 2 To Sheets.Count
If Sheets(k).Name = "空白" Then
ShaiXuan = "="
Else
ShaiXuan = Sheets(k).Name
End If
sht0.Range(sht0.Cells(1, 1), sht0.Cells(iRow, iColumn)).AutoFilter Field:=L, Criteria1:=ShaiXuan
sht0.Range(sht0.Cells(1, 1), sht0.Cells(iRow, iColumn)).Copy Sheets(k).Range("a1")
Next
'让表格处于筛选状态，并选中数据表
sht0.Range(sht0.Cells(1, 1), sht0.Cells(iRow, iColumn)).AutoFilter
sht0.Range(sht0.Cells(1, 1), sht0.Cells(iRow, iColumn)).AutoFilter
sht0.Select
Msg = 0
Msg = MsgBox("拆分成功！" & Chr(13) & "请确认是否需要将拆分出来的多表另存为单个文件" & Chr(13) & "存放目录若有相同名字的表将被替换", 65, "<<<<拆分出来的多表另存确认>>>>")
'MsgBox msg
If Msg = 2 Then
Exit Sub
End If
'人工选取存放的路径
Title = "请选择分表后存放的目录"
'调用自定义函数获取路径地址
objFD = GetFileDialogFolderPicker(Title)
'若用户在弹出的选择窗口上点了取消则退出
If objFD = "" Then
Exit Sub
End If
'调用表格另存为的方法
Call Excel_Auto_SaveAs(objFD)
MsgBox "处理完成", , "完成"
End Sub
'弹出对话框让用户选择列
Function Get_Column_Num(ByVal Msg As String, ByVal Tit As String, ByVal Typ As Integer) As Long
'下面的代码弹出提示框让用户选择要按那列进行拆分表
sCol = Application.InputBox(Msg, Tit, Type:=Typ) '0=公式，1=数字，2=文本，4=逻辑值，8=单元格引用，16=错误值，64=数值数组
'MsgBox VarType(sCol)
'用[VarType 数据类型]判断用户的输入类型
If VarType(sCol) = 11 Then '点击了取消则返回0
Get_Column_Num = 0
ElseIf VarType(sCol) = 8 Then '输入了文本类型就进行转换成数字
Get_Column_Num = Range(sCol & 1).Column
ElseIf VarType(sCol) = 5 Then '输入的是数字就直接取数字
Get_Column_Num = sCol
End If
End Function
'获取用户选择的路径函数
Function GetFileDialogFolderPicker(ByVal Tit As String)
'人工选取存放的路径
Set objFD = Application.FileDialog(msoFileDialogFolderPicker)
With objFD
.Title = Tit
If .Show = -1 Then
' 如果单击了确定按钮，则将选取的路径保存在变量中
sPath = .SelectedItems(1) & "\"
'MsgBox sPath
End If
End With
GetFileDialogFolderPicker = sPath
'MsoFileDialogType 可为下述常量之一:
'msoFileDialogFilePicker 允许用户选择文件
'msoFileDialogFolderPicker 允许用户选择文件夹
'msoFileDialogOpen 允许用户打开文件
'msoFileDialogSaveAs 允许用户保存文件
End Function
'实现表格另存为并将同名表替换
Sub Excel_Auto_SaveAs(objFD As String)
Dim sht As Worksheet
Application.ScreenUpdating = False '屏幕更新事件关闭
Application.DisplayAlerts = False '警告事件关闭
'On Error Resume Next '出现错误执行下步代码，比如保存的位置有相同文件名的表
For Each sht In Sheets
If Dir(objFD & sht.Name & ".xlsx") = sht.Name & ".xlsx" Then '判断若表格已经存在就先删除表格
Kill objFD & sht.Name & ".xlsx" '删除表格
End If
sht.Copy
ActiveWorkbook.SaveAs Filename:=objFD & sht.Name & ".xlsx"
ActiveWorkbook.Close
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
