前面我們發布過将多個Excel工作簿中的工作表合并到一個工作表簿中，就有網友提了一個問題，如何講一個Excel工作簿中的工作表拆分成多個工作表，其實實現的方法很多，如果數據少的話，我們直接采用Excel的篩選，然後複制粘貼就可以了，如果數據比較多，或者是日常工作的話，每天這樣複制粘貼，就很麻煩~，或者我們使用透視表也可以。我們這講就來使用VBA的方法來實現，這個方法很簡單，隻需要複制代碼（代碼也是小編從網上找的，然後修改了下，這樣通用性就更強了，更多精彩請關注公衆号：word_excel_ppt），運行就可以了。

1、素材文件

素材文件

我們的素材文件是以某公司為例，數據記錄了公司旗下有7家店鋪，從2016年1月1日到2018年12月31日，每天銷售的流水數據。

存放數據的工作表名稱已修改為“數據源”，工作表的第一行為标題行，一共有2195行數據。

現在我們想按照店鋪名稱，将整個工作表拆分開。

2、操作步驟

打開我們的工作表文件以後，将需要拆分的工作表名字修改成“數據源”。然後按鍵盤上面的Alt F11，彈出VBA編輯的窗口，将代碼粘貼進代碼編輯器中（代碼見最後附件）；

代碼窗口

重要的事情重複一次，因為我們代碼裡面，要拆分的工作表名稱叫"數據源"，所以你直接把你要拆分的工作表名稱修改成“數據源”才能正常運行。

3、運行程序

在VBA編輯器中，點擊示例中的綠色三角（見上圖），或者是按鍵盤上面的F5都可以。

選擇标題行

此時會讓我們選擇标題行，我們通過鼠标點擊标記标題行（第1行）就可以了；

選擇拆分字段

接下來會讓我們選擇，需要按照哪個字段拆分，我們就選擇門店名稱（B1）單元格，然後直接點确定。

搞定

這個時候程序就會自動運行，鼠标會閃動，我們需要等一下，運行的時間就和你電腦的配置以及要拆分文件的大小有關，以我們的素材為例，大概需要10秒鐘，就可以搞定，然後會彈出一個提示完成的消息框，我們點确定就可以。

運行結果

回到我們的文件裡面，可以看到程序已經給我們拆分好了，是不是覺得很方便呢？

附程序代碼（程序在Win7 Excel 2016 運行可行）：

視頻演示，稍後發布在頭條專欄中

Sub 按照指定字段拆分工作表() '本程序來源于網絡，原作者不詳，特留此句對原作者表示感謝； '本程序中，雲淡風輕微課堂(公衆号:word_excel_ppt)進行了部分修改，适用性更廣 Dim myRange As Variant Dim myArray Dim titleRange As Range Dim title As String Dim columnNum As Integer myRange = Application.InputBox(prompt:="請用鼠标點擊标題行：", Type:=8) myArray = WorksheetFunction.Transpose(myRange) Set titleRange = Application.InputBox(prompt:="請用鼠标點擊要拆分的字段，必須是第一行，且為1個單元格", Type:=8) title = titleRange.Value columnNum = titleRange.Column Application.ScreenUpdating = False Application.DisplayAlerts = False Dim i&, Myr&, Arr, num& Dim d, k For i = Sheets.Count To 1 Step -1 If Sheets(i).Name <> "數據源" Then Sheets(i).Delete End If Next i Set d = CreateObject("Scripting.Dictionary") Myr = Worksheets("數據源").UsedRange.Rows.Count Arr = Worksheets("數據源").Range(Cells(2, columnNum), Cells(Myr, columnNum)) For i = 1 To UBound(Arr) d(Arr(i, 1)) = "" Next k = d.keys For i = 0 To UBound(k) Set conn = CreateObject("adodb.connection") Select Case Application.Version * 1 '設置連接字符串,根據版本創建連接 Case Is <= 11 conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & ThisWorkbook.FullName Case Is >= 12 conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES"";""" End Select Sql = "select * from [數據源$] where " & title & " = '" & k(i) & "'" Worksheets.Add after:=Sheets(Sheets.Count) With ActiveSheet .Name = k(i) For num = 1 To UBound(myArray) .Cells(1, num) = myArray(num, 1) Next num .Range("A2").CopyFromRecordset conn.Execute(Sql) End With Sheets(1).Select Sheets(1).Cells.Select Selection.Copy Worksheets(Sheets.Count).Activate ActiveSheet.Cells.Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Next i conn.Close Set conn = Nothing Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox " 已經拆分完成" & vbCrLf & vbCrLf & "更多内容敬請關注公衆号:word_excel_ppt", vbInformation, "雲淡風輕微課堂" End Sub

更多精彩請關注公衆号：word_excel_ppt

更多精彩资讯请关注tft每日頭條，我们将持续为您更新最新资讯!