拆分字段区分_学会利用Excel总表字段拆分工作表，你就是部门最靓的仔！

分列时让超过15位的数字不变成科学计数法

Excel情报局

生产搬运分享Excel基础技能

OFFICE知识新青年

用1%的Excel基础搞定99%的日常工作

做一个有文艺范的Excel公众号

Excel是门手艺 玩转需要勇气

边听边学，阅读文章更轻松

下表是工作表名称为"总表"的数据源表格。

如何将上表，以组别为区分标准，将3个组别所含内容分别生成3个单独的工作表，且工作表名称以组别字段命名，分别为1组、2组、3组。

普通青年可能会选择最原始的方法操作：新建出3个工作表-分别将这3个工作表右击重命名为1组、2组、3组-最终将总表内容一一复制粘贴到分表中。假设总表数据量很大的情况，普通青年可就累个半死了。

我们只需要复制粘贴一段VBA代码就可以轻松批量瞬间搞定这个问题。

首先右击总表-查看代码-复制粘贴VBA代码。

将这段代码中的所有的"公众号Excel情报局"字段，全部查找替换为你的主表数据源表格的工作表名称，本例中即"总表"。

Ctrl+F，调出查找功能框，复制粘贴或者输入查找内容：公众号Excel情报局，替换内容输入：总表，点击全部替换即可。

点击运行代码。

弹出请选择标题行，选择标题行区域，即表格第一行区域，确定。

弹出请选择拆分的表头，必须是第一行，且为一个单元格，选择组别单元格，即A1单元格，确定。

等待几秒即可自动拆分完成。

代码如下，复制粘贴即用。

注：使用时请将代码中的"公众号Excel情报局"字段全部查找替换为你现实中的总表数据源的工作表名称。

Sub CFGZB()

    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:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", 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 <> "公众号Excel情报局" Then

            Sheets(i).Delete

        End If

    Next i

    Set d = CreateObject("Scripting.Dictionary")

    Myr = Worksheets("公众号Excel情报局").UsedRange.Rows.Count

    Arr = Worksheets("公众号Excel情报局").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")

        conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName

        Sql = "select * from [公众号Excel情报局$] 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

End Sub

-----------------------

视频解析：

不要对任何一个Excel知识点定义为无用论，因为只有合适的问题在合适的模型运用合适的Excel技巧，才能实现其最大作用。所以你的知识储备很重要！

隔三差五学个Excel小知识，忘记一天工作的烦恼，只要坚持，最后可能不会得到最好的结果，但一定不会收获最坏的结果。赖床舒服，但可能迟到；熬夜很爽，但伤身体。自律或许并不容易，但你越懒惰越放纵自己，就越可能错过美好的人和事。如果生活注定充满艰辛，那就学着做拯救自己的那个英雄。趁年轻不妥协，向前奔跑！从今天开始改变，对平庸生活奋力回击。

  

  往期知识点精彩链接点击阅读！

【Office2003~2019简体中文版下载】【WPS表格2019版开启VBA宏功能】【全网文字任你免费复制的小技巧】【快速提取Excel表格的所有图片】【微信朋友圈空白说说这样操作】【Excel电话号码导入手机通讯录】【批量合并工作簿下所有工作表】【材料出入库电子表格模板分享】【30套炫卡通风格PPT模板分享】【40套酷梦幻风格PPT模板分享】【备考公务员之公文写作大全】【Excel财务账模板超级实用】【再不怕忘记电脑开机密码】【电脑微信多开的方法】【Excel制作公章方法】【电脑重装系统方法】【Excel卸载小工具】【工作簿合并工具】