批量將工作表轉(zhuǎn)換為獨(dú)立工作簿

批量將工作表轉(zhuǎn)換為獨(dú)立工作簿SubNewbooks()

'EH技術(shù)論壇。VBA編程學(xué)習(xí)與實(shí)踐?？匆?jiàn)星光

DimshtAsWorksheet,strPath$

WithApplication.FileDialog(msoFileDialogFolderPicker)

'選擇保存工作薄的文件路徑

If.ShowThen

strPath=.SelectedItems(1)

'讀取選擇的文件路徑

Else

ExitSub

'如果沒(méi)有選擇保存路徑，則退出程序

EndIf

EndWith

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

Application.DisplayAlerts=False

'取消顯示系統(tǒng)警告和消息，避免重名工作簿無(wú)法保存。當(dāng)有重名工作簿時(shí)，會(huì)直接覆蓋保存。

Application.ScreenUpdating=False

'取消屏幕刷新

ForEachshtInWorksheets

'遍歷工作表

sht.Copy

'復(fù)制工作表，工作表單純復(fù)制后，會(huì)成為活動(dòng)工作薄

WithActiveWorkbook

.SaveAsstrPath&sht.Name,xlWorkbookDefault

'保存活動(dòng)工作薄到指定路徑下，以默認(rèn)文件格式

.CloseTrue'關(guān)閉工作薄并保存

EndWith

Next

Application.ScreenUpdating=True'恢復(fù)屏幕刷新

Application.DisplayAlerts=True'恢復(fù)顯示系統(tǒng)警告和消息

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

EndSub一鍵將總表數(shù)據(jù)拆分為多個(gè)分表SubNewShts()

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

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

Application.ScreenUpdating=False

'關(guān)閉屏幕更新

Application.DisplayAlerts=False

'關(guān)閉警告信息提示

Setd=CreateObject("scripting.dictionary")

'set字典

SetRg=Application.InputBox("請(qǐng)框選拆分依據(jù)列！只能選擇單列單元格區(qū)域！",Title:="提示",Type:=8)

'用戶選擇的拆分依據(jù)列

tCol=Rg.Column

'取拆分依據(jù)列列標(biāo)

tRow=Val(Application.InputBox("請(qǐng)輸入總表標(biāo)題行的行數(shù)？"))

'用戶設(shè)置總表的標(biāo)題行數(shù)

IftRow=0ThenMsgBox"你未輸入標(biāo)題行行數(shù)，程序退出。":ExitSub

SetRng=ActiveSheet.UsedRange

'總表的數(shù)據(jù)區(qū)域

arr=Rng

'數(shù)據(jù)范圍裝入數(shù)組arr

tCol=tCol-Rng.Column+1

'計(jì)算依據(jù)列在數(shù)組中的位置

aCol=UBound(arr,2)

'數(shù)據(jù)源的列數(shù)

Fori=tRow+1ToUBound(arr)

'遍歷數(shù)組arr

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

d(arr(i,tCol))=i

'字典中不存在關(guān)鍵詞則將行號(hào)裝入字典

Else

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

'如果存在則合并行號(hào)，以逗號(hào)間隔

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里儲(chǔ)存的行號(hào)

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

'聲明放置結(jié)果的數(shù)組brr

k=0

Forx=0ToUBound(r)

k=k+1

'累加記錄行數(shù)

Forj=1ToaCol

'循環(huán)讀取列

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

Next

Next

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

'新建一個(gè)工作表，位置在所有已存在sheet的后面

.Name=kr(i)

'表格命名

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

'放標(biāo)題行

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

'放置數(shù)據(jù)區(qū)域

Rng.Copy

'復(fù)制粘貼總表的格式

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

.[a1].Select

EndWith

EndIf

Next

Sheets(1).Activate

'激活第一個(gè)表格

Setd=Nothing

'釋放字典

Erasearr:Erasebrr

'釋放數(shù)組

MsgBox"數(shù)據(jù)拆分完成！"

Application.ScreenUpdating=True

'恢復(fù)屏幕更新

Application.DisplayAlerts=True

'恢復(fù)警示

EndSub一鍵匯總各分表數(shù)據(jù)到總表Subcollect()

'VBA編程學(xué)習(xí)與實(shí)踐，一鍵多表數(shù)據(jù)匯總

DimshtAsWorksheet,rngAsRange,k&,trow&

Application.ScreenUpdating=False

'取消屏幕更新，加快代碼運(yùn)行速度

trow=Val(InputBox("請(qǐng)輸入標(biāo)題的行數(shù)","提醒"))

Iftrow<0ThenMsgBox"標(biāo)題行數(shù)不能為負(fù)數(shù)。",64,"警告":ExitSub

'取得用戶輸入的標(biāo)題行數(shù)，如果為負(fù)數(shù)，退出程序

Cells.ClearContents

'清空當(dāng)前表數(shù)據(jù)

ForEachshtInWorksheets

'循環(huán)讀取表格

Ifsht.Name<>ActiveSheet.NameThen

'如果表格名稱不等于當(dāng)前表名則進(jìn)行匯總動(dòng)作……

Setrng=sht.UsedRange

'定義rng為表格已用區(qū)域

k=k+1

'累計(jì)K值

Ifk=1Then

'如果是首個(gè)表格，則K為1，則把標(biāo)題行一起復(fù)制到匯總表

rng.Copy

[a1].PasteSpecialPaste:=xlPasteValues

Else

'否則，扣除標(biāo)題行后再?gòu)?fù)制黏貼到總表，只黏貼數(shù)值

rng.Offset(trow).Copy

Cells