今年5月份我們在Excel表哥微信公衆号平台首發了一系列
工作表、
工作簿合并的文章。
從合并相同内容的
單元格到合并多個
工作表直至批量合并多個Excel
工作簿，所有的操作隻需要一鍵！
專輯如下，也可以在表哥公衆号底部菜單欄左側【來份幹貨】找到。
有讀者給表哥留言既然有合并工作簿工作表的工具，怎麼能沒有一鍵拆分的工具呢？
讀者朋友的提問其實也讓我們看到了大家平時工作上的需求，Excel表哥公衆号也樂于幫助讀者解決Excel應用方面的任何問題。
是以我們今天特意制作這篇一鍵拆分工作表，生成若幹新表或者工作簿的方法分享給大家。
今天的分享給大家展示在日常工作中VBA是如何成百上千倍地幫助提高我們的工作效率的！
01
案例分享
以一位讀者朋友的提問為案例。我們希望将資訊總表每一行的彙總資訊按照
基本資訊表中給定的格式拆分為不同的工作表/工作簿。
如果不借助VBA，正常的做法一般是不斷的在兩個工作表或者工作簿之間來回複制粘貼。想象一下如果這個彙總表有上百行資料，這種重複的操作将會非常無趣且容易出錯。
02
VBA一鍵操作
針對這種重複性的操作，其實Excel中内置的VBA非常有幫助。首先來看下一鍵拆分的效率有多高：
針對案例中的拆分需求 以6行資料為例
拆分為6個工作表用時1s，拆分為6個獨立的工作簿，用時5s。相比較人工複制粘貼，效率提高豈止上千倍！
03
代碼解析
大家不用把VBA想象的太複雜，整個程式不是很長，也不用自己每一行都手敲代碼。
通過錄制宏并稍作修改就可以完成這些基本操作，當然前提是還是需要稍微懂一點點VBA常識。
詳細代碼如下，具體語句作用參考代碼注釋。
Sub 工作表拆分()
Dim Wb, Sht, msht, NewSht, rng
Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets("資訊總表")
Set msht = Wb.Worksheets("基本資訊")
With Sht
endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
If endrow <= 1 Then Exit Sub
Set rng = .Range("A2:O" & endrow)
arr = rng.Value
End With
Tempelate = "工作簿拆分工具"
sel = Val(Application.InputBox("選擇拆分至工作表還是工作簿 " & vbNewLine & vbNewLine & "1：工作表 2: 工作簿", Title:=Tempelate, Default:=1, Type:=1))
If sel = 0 Then Exit Sub
timenow = Time
For i = LBound(arr) To UBound(arr)
msht.Copy After:=Wb.Worksheets(Wb.Worksheets.Count) '基本資訊表複制至新表
Set NewSht = Wb.Worksheets(Wb.Worksheets.Count)
With NewSht
newname = arr(i, 3) '以第三列的姓名來給新表格命名
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next '删除工作表可能會出現錯誤，此處忽略錯誤繼續執行
Wb.Worksheets(newname).Delete '删除工作表
'下面是每個子表格的填寫操作
.Name = newname
.Range("B2").Value = arr(i, 3) '小表B2單元格的内容=大表的第3列的姓名，以此類推
'.... '以此類推，需根據自己的需要調整修改
.Range("B6").Value = arr(i, 9)
If sel = 2 Then '另存為新工作簿
ActiveSheet.Select
ActiveSheet.Move
ChDir ThisWorkbook.Path
ActiveWorkbook.SaveAs Filename:=arr(i, 3) & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
End If
End With
Next i
Windows(Wb.Name).Activate
Wb.Sheets("資訊總表").Select
Application.ScreenUpdating = True
Set Wb = Nothing
Set Sht = Nothing
Set msht = Nothing
Set NewSht = Nothing
Set rng = Nothing
timeuse = Round((Time - timenow) * 24 * 60 * 60, 2)
If sel = 2 Then
MsgBox "Done!" & vbNewLine & "拆分的工作簿位于目前路徑！" & vbNewLine & "總共用時 " & timeuse & "s", Title:=Tempelate
Else
MsgBox "Done!" & vbNewLine & "拆分的内容位于目前工作簿！" & vbNewLine & "總共用時 " & timeuse & "s", Title:=Tempelate
End If
End Sub
▲左右滑動檢視完整代碼
将這段sub程式宏代碼指定至一個按鍵，之後如動圖示範，隻需點選此按鍵就可以一鍵完成工作表的拆分。
而且還可以根據自己的需要選擇拆分為新的工作表或者工作簿，十分人性化。
因為每個人的表格設計的都不一樣，子表格的填表這段代碼就留給讀者自己來修改吧。
大家也可以下載下傳模闆進行對照練習，讀者朋友可關注公衆号并在下方的留言區擷取背景下載下傳關鍵詞哦~ 專輯檢視方式 注：本公衆号所載原創文章均為作者辛苦創作，轉載請聯系作者并标明出處。
處處留心皆學問，建議大家可以将這篇推文收藏，以備不時之需。
原文及下載下傳位址：
一鍵批量拆分Excel工作表【模闆下載下傳】mp.weixin.qq.com