将一个工作表拆分成多个工作簿(工作表分成多个工作簿)

首先说业务背景，某公司总部，需要每月跟各分公司确认销售人员的业绩提成，这里有一份根据奖励政策汇总统计所有分公司的销售业绩提成表，表格如下。

以上表格，之一列是销售人员编号，第二列是销售人员所属分公司，第三列是每个销售人员的业绩提成。

那我们需要做什么事呢？

我们需要将各个分公司的数据分开，保存到一个新的表格里，最后另存为一个新的工作簿。

最终的效果如下图所示。

如果手动去拆分，大致分为以下三步。

针对每个分公司，分别新建一个工作表。
将每个分公司的数据筛选出来，保存到对应的工作表里。
将每个分公司的工作表另存为新的工作簿。

如果以上这些操作每月都要进行，但是，对于汇总完的数据，按照分公司分离到新表，再另存为新的工作簿完全是一个重复性的“体力活”，而且每月都会浪费一定的时间。

如果通过VBA来解决，前期只要把代码编写好，以后每月执行一次就可以完成任务，可以节省大量的时间。

温馨提示：阅读以下内容需要一定的VBA基础哦。

接下来，说说如何用VBA代码实现。

之一步：新建工作表

按照上表中的分公司名称创建新工作表，VBA代码如下。

Sub shtAdd()
    Dim sht As Worksheet, i As Integer   '新建一个worksheet对象
    i = 2    Set sht = Worksheets("业绩提成表")    Do While sht.Cells(i, "B") <> ""
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = sht.Cells(i, "B").Value
    i = i + 1
    LoopEnd Sub

上述代码的意思就是通过一个循环对B列中的分公司名称进行循环，即对每一个分公司名称建一个新工作表，并将分公司名称作为新工作表的名称。

可是，这样做有一个问题，B列中的分公司名称有重复，一旦遇到之前创建过工作表的分公司名称，再创建工作表就会出现如下图所示的错误。

因为Excel工作表的名称是不能重复的，所以，需要考虑重复的情况。

第二步：考虑重复的新建工作表

考虑到重复，将前面的VBA代码修改一下。

Sub shtAdd()
    Dim sht As Worksheet, i As Integer
    i = 2    Set sht = Worksheets("业绩提成表")    
    Do While sht.Cells(i, "B") <> ""
        On Error Resume Next
        If Worksheets(sht.Cells(i, "B").Value) Is Nothing Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = sht.Cells(i, "B").Value        End If
    i = i + 1
    LoopEnd Sub

上述代码主要修改了两个地方：

1、在循环中增加一个if条件判断，表示当某个分公司名称的表格不存在时，就创建一个新的工作表。

2、增加了一行代码On Error Resume Next，表示当发生错误时，忽略错误，继续执行下一行。

为啥要增加这行代码？

但是当Worksheets(sht.Cells(i, "B").Value)不存在时，会报错。

执行上述VBA代码，就完成了新建工作表，如下图所示。

第三步：批量对数据分类

此时的新工作表还没有数据，所以需要将每个分公司的数据筛选出来，然后分别复制到各个分公司的新工作表中。

VBA代码如下。

Sub fenlei()
    Dim i As Integer, cName As String, rng1 As Range, rng2 As Range
    i = 2
    Worksheets("业绩提成表").Select
    cName = Cells(i, "B").Value    Do While cName <> ""
        Set rng1 = Worksheets(cName).Range("A1")
        Cells(1, "A").Resize(1, 3).Copy rng1
        
        Set rng2 = Worksheets(cName).Range("A1000").End(xlUp).Offset(1, 0)
        Cells(i, "A").Resize(1, 3).Copy rng2
        i = i + 1
        cName = Cells(i, "B").Value
    Loop
End Sub

上述代码的意思就是通过一个循环去遍历原来的工作表，将每一条记录按照分公司名称复制到之前新建的工作表中，只是每次循环的时候都将表头，也就是之一行的字段名称，也复制到每个工作表的之一行。

第四步：将工作表保存为新工作簿

此时，每个分公司对应的工作表中已经有了数据，如下图所示。

接下来需要将每个工作表都保存为一个单独的工作簿，VBA代码如下。

Sub saveTowb()
    Application.ScreenUpdating = False
    Dim dir As String
    dir = ThisWorkbook.Path & "\各分公司业绩表"
    Dim sht As Worksheet
    
    For Each sht In Worksheets
        sht.Copy
        ActiveWorkbook.SaveAs dir & "\" & sht.Name & ".xlsx"
        ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = TrueEnd Sub

以上VBA代码的意思是将每个工作表保存到当前路径下的“各分公司业绩表”文件夹中，并且命名为工作表的名称，最终拆分出来的表格如下所示。