附：源码
Sub工作表拆分()
''----------------------------------------------------
''自定义各数据类型
DimSplitcol,Headrow,rngAsRange
DimColnumAsInteger,Head_countAsByte,Arr,Lastrow,i,Shtindex,OnlyAsNewCollection
DimMsg,New_wk
OnErrorResumeNext
''-----------------------------------------------------
''指定需要的拆分条件列
SetSplitcol=Application.InputBox("选择整列\或所在的任意单元格均可","选择指定拆分条件的所在列",Type:=8)
IfErr.Number>0ThenMsgBox"未选择内容":ExitSub
IfWorksheetFunction.CountA(Splitcol.EntireColumn)=0ThenMsgBox"选择的列内容为空":ExitSub
''-----------------------------------------------------
''设置标题行
SetHeadrow=Application.InputBox("选择整个行区域\或行所在区域的任意单元格均可","选择标题行",Type:=8)
IfErr.Number>0ThenMsgBox"未选择内容":ExitSub
Head_count=Headrow.Rows.Count
IfHead_count>=Splitcol.Parent.UsedRange.Rows.CountThenExitSub
OnErrorGoTo0
Msg=MsgBox("选择是—拆分为工作表"&Chr(10)&"选择否—拆分为工作薄",vbYesNo,"自定义拆分类型")
WithSplitcol.Parent
Colnum=Splitcol.Column
Lastrow=.UsedRange.Rows.Count
''-------------------------------------------------
''对需要拆分的条件列的值剔除重复值，利用Colection有序集合的成员不能存在重复内容的作用
Arr=.Range(.Cells(Head_count+1,Colnum),.Cells(Lastrow,Colnum))
OnErrorResumeNext
Fori=1ToLastrow-Head_count
IfLen(Arr(i,1))>0ThenOnly.AddCStr(Arr(i,1)),CStr(Arr(i,1))
Nexti
Application.ScreenUpdating=False''关闭屏幕更新，加快执行速度
Application.DisplayAlerts=False''关闭显示特定的警告和消息，删除已经存在相同名字的工作表时，不弹出消息
IfMsg=vbYesThen''判断不同的拆分类型
''拆分为工作表
Fori=1ToOnly.Count
Err.Clear
Sheets.Addafter:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Sheets(Sheets.Count).Name=Only(i)
IfErr.Number>0ThenSheets(Only(i)).Delete:Sheets(Sheets.Count).Name=Only(i)
Nexti
''------------------------------------------------
''利用筛选、复制可见内容的方式，分别将表格的内容拆分到各分表中
.AutoFilterMode=False
Fori=1ToOnly.Count
.Range(.Cells(Head_count,1),.Cells(Lastrow,Colnum)).AutoFilterField:=Colnum,Criteria1:=Only(i)
.UsedRange.SpecialCells(xlCellTypeVisible).Copy
ThisWorkbook.Sheets(Only(i)).Paste
ThisWorkbook.Sheets(Only(i)).Cells.EntireColumn.AutoFit
Nexti
.AutoFilterMode=False
Else
''拆分为工作薄
.AutoFilterMode=False
Fori=1ToOnly.Count
Err.Clear
SetNew_wk=Workbooks.Add
New_wk.SaveAsFilename:=ThisWorkbook.Path&"\"&Only(i)
.Range(.Cells(Head_count,1),.Cells(Lastrow,Colnum)).AutoFilterField:=Colnum,Criteria1:=Only(i)
.UsedRange.SpecialCells(xlCellTypeVisible).CopyDestination:=Workbooks(Only(i)&".xlsx").Sheets(1).Range("a1")
Workbooks(Only(i)&".xlsx").Sheets(1).Cells.EntireColumn.AutoFit
Workbooks(Only(i)&".xlsx").Save
Workbooks(Only(i)&".xlsx").Close
Nexti
.AutoFilterMode=False
EndIf
EndWith
Application.ScreenUpdating=True
Application.DisplayAlerts=True
ThisWorkbook.Save
MsgBox"拆分完毕"
EndSub |
|
