批量将工作表转换为独立工作簿

批量将工作表转换为独立工作簿SubNewbooks()

'EH技术论坛。VBA编程学习与实践。看见星光

DimshtAsWorksheet,strPath$

WithApplication.FileDialog(msoFileDialogFolderPicker)

'选择保存工作薄的文件路径

If.ShowThen

strPath=.SelectedItems(1)

'读取选择的文件路径

Else

ExitSub

'如果没有选择保存路径，则退出程序

EndIf

EndWith

IfRight(strPath,1)<>"\"ThenstrPath=strPath&"\"

Application.DisplayAlerts=False

'取消显示系统警告和消息，避免重名工作簿无法保存。当有重名工作簿时，会直接覆盖保存。

Application.ScreenUpdating=False

'取消屏幕刷新

ForEachshtInWorksheets

'遍历工作表

sht.Copy

'复制工作表，工作表单纯复制后，会成为活动工作薄

WithActiveWorkbook

.SaveAsstrPath&sht.Name,xlWorkbookDefault

'保存活动工作薄到指定路径下，以默认文件格式

.CloseTrue'关闭工作薄并保存

EndWith

Next

Application.ScreenUpdating=True'恢复屏幕刷新

Application.DisplayAlerts=True'恢复显示系统警告和消息

MsgBox"处理完成。",,"提醒"

EndSub一键将总表数据拆分为多个分表SubNewShts()

DimdAsObject,shtAsWorksheet,arr,brr,r,kr,i&,j&,k&,x&

DimRngAsRange,RgAsRange,tRow&,tCol&,aCol&,pd&

Application.ScreenUpdating=False

'关闭屏幕更新

Application.DisplayAlerts=False

'关闭警告信息提示

Setd=CreateObject("scripting.dictionary")

'set字典

SetRg=Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！",Title:="提示",Type:=8)

'用户选择的拆分依据列

tCol=Rg.Column

'取拆分依据列列标

tRow=Val(Application.InputBox("请输入总表标题行的行数？"))

'用户设置总表的标题行数

IftRow=0ThenMsgBox"你未输入标题行行数，程序退出。":ExitSub

SetRng=ActiveSheet.UsedRange

'总表的数据区域

arr=Rng

'数据范围装入数组arr

tCol=tCol-Rng.Column+1

'计算依据列在数组中的位置

aCol=UBound(arr,2)

'数据源的列数

Fori=tRow+1ToUBound(arr)

'遍历数组arr

IfNotd.exists(arr(i,tCol))Then

d(arr(i,tCol))=i

'字典中不存在关键词则将行号装入字典

Else

d(arr(i,tCol))=d(arr(i,tCol))&","&i

'如果存在则合并行号，以逗号间隔

EndIf

Next

ForEachshtInWorksheets

'遍历一遍工作表，如果字典中存在则删除

Ifd.exists(sht.Name)Thensht.Delete

Next

kr=d.keys

'字典的key集

Fori=0ToUBound(kr)

'遍历字典key值

Ifkr(i)<>""Then

'如果key不为空

r=Split(d(kr(i)),",")

'取出item里储存的行号

ReDimbrr(1ToUBound(r)+1,1ToaCol)

'声明放置结果的数组brr

k=0

Forx=0ToUBound(r)

k=k+1

'累加记录行数

Forj=1ToaCol

'循环读取列

brr(k,j)=arr(r(x),j)

Next

Next

WithWorksheets.Add(,Sheets(Sheets.Count))

'新建一个工作表，位置在所有已存在sheet的后面

.Name=kr(i)

'表格命名

.[a1].Resize(tRow,aCol)=arr

'放标题行

.[a1].Offset(tRow,0).Resize(k,aCol)=brr

'放置数据区域

Rng.Copy

'复制粘贴总表的格式

.[a1].PasteSpecialPaste:=xlPasteFormats,Operation:=xlNone,SkipBlanks:=False,Transpose:=False

.[a1].Select

EndWith

EndIf

Next

Sheets(1).Activate

'激活第一个表格

Setd=Nothing

'释放字典

Erasearr:Erasebrr

'释放数组

MsgBox"数据拆分完成！"

Application.ScreenUpdating=True

'恢复屏幕更新

Application.DisplayAlerts=True

'恢复警示

EndSub一键汇总各分表数据到总表Subcollect()

'VBA编程学习与实践，一键多表数据汇总

DimshtAsWorksheet,rngAsRange,k&,trow&

Application.ScreenUpdating=False

'取消屏幕更新，加快代码运行速度

trow=Val(InputBox("请输入标题的行数","提醒"))

Iftrow<0ThenMsgBox"标题行数不能为负数。",64,"警告":ExitSub

'取得用户输入的标题行数，如果为负数，退出程序

Cells.ClearContents

'清空当前表数据

ForEachshtInWorksheets

'循环读取表格

Ifsht.Name<>ActiveSheet.NameThen

'如果表格名称不等于当前表名则进行汇总动作……

Setrng=sht.UsedRange

'定义rng为表格已用区域

k=k+1

'累计K值

Ifk=1Then

'如果是首个表格，则K为1，则把标题行一起复制到汇总表

rng.Copy

[a1].PasteSpecialPaste:=xlPasteValues

Else

'否则，扣除标题行后再复制黏贴到总表，只黏贴数值

rng.Offset(trow).Copy

Cells