1、工作簿按具体字段拆分为工作簿

Sub 同步拆分()

    MsgBox "开始运行"

    Application.ScreenUpdating = False

    '创建一个字典对象

    Set d = CreateObject("Scripting.Dictionary")

    '定义当前的工作簿

    Set wb1 = ThisWorkbook

    '遍历当前工作簿的所有sheet

    Set group = Application.InputBox(prompt:="请输入需要拆分的字段为", Type:=8)

    For Each Sht In Sheets

        '获取当前sheet的所有动态区域

        ara = Sht.[a1].CurrentRegion

        'UBound该区域的列数，for 循环

        'MsgBox UBound(ara, 2)

        For i = 1 To UBound(ara, 2)

            '取到第一行中的需要拆分的字段名，几张表就有几个J

            If ara(1, i) = group Then j = i: Exit For

        Next

        '第几行开始计算，如果表头为2行，则为i=3

        For i = 2 To UBound(ara)

            d(ara(i, j)) = ""

        Next

    Next

    k = d.keys: t = d.items

    '字典里存了多少的key（多少关键字）来创建多少张表，为什么用这个字典是为了去重

    For i = 0 To UBound(k)

        Application.SheetsInNewWorkbook = wb1.Sheets.Count

        Workbooks.Add

        Set wb = ActiveWorkbook

        With wb

        '针对新建工作簿的每个sheet进行操作

            For x = 1 To wb1.Sheets.Count

                '取待拆分表的范围

                ara = wb1.Sheets(x).[a1].CurrentRegion

                '复制从第几行开始 m

                m = 2

                '找到需要拆分的列，并把列数赋值给jj

                For j = 1 To UBound(ara, 2)

                    If ara(1, j) = group Then jj = j: Exit For

                Next

                '第几行开始计算，如果表头为2行，则为j=3

                For j = 2 To UBound(ara)

                    '判断某个字段等于字典key，即把挨个片区的内容copy出来

                    If ara(j, jj) = k(i) Then

                        '拷贝数据至目标表的第2行开始依次拷贝

                        wb1.Sheets(x).Cells(j, 1).Resize(1, UBound(ara, 2)).Copy .Sheets(x).Cells(m, 1)

                        '拷贝表头

                        wb1.Sheets(x).Cells(1, 1).Resize(1, UBound(ara, 2)).Copy .Sheets(x).[a1]

                        m = m + 1

                    End If

                Next

                '命名sheetname

                'MsgBox wb1.Sheets(x).Name

                .Sheets(x).Name = wb1.Sheets(x).Name

                '设置单位格线

                .Sheets(x).[a2].CurrentRegion.Borders.LineStyle = 1

                For y = 1 To UBound(ara, 2)

                    '设置列宽

                  .Sheets(x).Columns(y).ColumnWidth = wb1.Sheets(x).Columns(y).ColumnWidth

                Next

            Next

        End With

        '保存wb

        wb.SaveAs ThisWorkbook.Path & "\" & Split(wb1.Name, ".")(0) & "(" & k(i) & ")" & ".xlsx"

        wb.Close

    Next

    '输出OK

    MsgBox "OK"

    '这个是关闭屏幕刷新，在涉及多文件操作，打开关闭excel文件，或者激活工作表等操作的时候，可以加快代码运行速度 FLASE

    Application.ScreenUpdating = True

End Sub

2、针对某工作表中的具体字段拆分工作表

Option Explicit

Option Base 1

Sub 按指定列分组拆分数据()

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Dim self As Worksheet

    Set self = ActiveSheet

    Dim nLastRowNum As Long

    Dim nLastColumnNum As Long

    Dim i As Long

    ' 删除其他的sheet

    For i = Sheets.Count To 1 Step -1

        If Sheets(i).Name <> self.Name Then

            Sheets(i).Delete

        End If

    Next i

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True 

    '获取全部数据范围

    nLastRowNum = Cells(Rows.Count, 1).End(xlUp).Row

    nLastColumnNum = Cells(nLastRowNum, Columns.Count).End(xlToLeft).Column

    '获取标题

    Dim titleRange As Range

    Set titleRange = Application.InputBox(prompt:="请选择标题区域：将要当做标题行的每一个单元格", Type:=8)

    ' 有效数据开始行

    Dim nRowValidData As Long

    nRowValidData = titleRange.Row + titleRange.Rows.Count

    ' 获取拆分列的信息,只需要列号

    Dim splitColumnRange As Range

    Set splitColumnRange = Application.InputBox(prompt:="请选择拆分的列：选择任何一个该列的单元格即可", Type:=8)

    Dim columnNumToSplit As Long

    columnNumToSplit = splitColumnRange.Column

    ' 需要拆分的值字典

    Dim splitValueDict As Object

    ' 辅助字典用来保证顺序

    Dim splitValueDictReverse As Object

    Dim indexArray() As Long

    Set splitValueDict = CreateObject("Scripting.Dictionary")

    Set splitValueDictReverse = CreateObject("Scripting.Dictionary")

    Dim cellValue As String

    Dim ws As Worksheet

    For i = nRowValidData To nLastRowNum Step 1

        cellValue = Cells(i, columnNumToSplit).Text

        '1. 创建新的sheet；

        '2. 拷贝标题信息到新的sheet

        If Not splitValueDict.Exists(cellValue) Then

            splitValueDict(cellValue) = i

            splitValueDictReverse(i) = cellValue

            Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))

            ws.Name = cellValue

            self.Activate

            titleRange.Copy _

                ws.Range(ws.Cells(titleRange.Row, titleRange.Column), ws.Cells(nRowValidData - 1, titleRange.Column))

        End If

        ' 拷贝其他内容

        Range(Cells(i, 1), Cells(i, nLastColumnNum)).Copy _

            GetLastPasteRangeBySheetName(cellValue, nLastColumnNum)

    Next i

End Sub

Public Function GetLastPasteRangeBySheetName(ByRef SheetName As String, columnNum As Long) As Variant

    Dim wks As Worksheet

    Dim nLastRowNum As Long

    Set wks = ActiveWorkbook.Worksheets(SheetName)

    nLastRowNum = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row

    Set GetLastPasteRangeBySheetName = wks.Range(wks.Cells(nLastRowNum + 1, 1), wks.Cells(nLastRowNum + 1, columnNum))

End Function

3、各工作表按表名直接拆分为工作簿

Sub 拆分到工作簿()

    Dim Sht As Worksheet, Wp As String, Wkb As Workbook

    Application.DisplayAlerts = False

    Set Wkb = ActiveWorkbook

    Wp = Wkb.Path

    For Each Sht In Wkb.Worksheets

        Sht.Select

        Sht.Copy

        ActiveWorkbook.SaveAs Filename:=Wp & "\" & Sht.Name & ".xlsx", FileFormat _

        :=xlOpenXMLWorkbook, CreateBackup:=False

        ActiveWorkbook.Close 0

    Next

    Application.DisplayAlerts = True

End Sub

附如何在Excel中执行宏代码

打开Excel 后 文件选项卡--选项--加载项

1）先加载开发工具

2）在开发工具选项卡下点击查看代码

3）执行代码宏，完成拆分目标