职场日常工作中繁杂重复性的事务总是那么令人生厌，譬如拆分一张Excel工作表。所谓拆分工作表一般指的是将一个总表按条件拆分成不同的独立工作表。对于此类问题，如果数据量不大，而且是一次性的工作，完全可以使用自动筛选，再复制、粘贴的方法来解决，也可以使用“数据透视表”来实现。如果碰到的数据量比较大，或者是一项经常性的工作，那么需要采用自动化的方式来实现。在Excel中我们可以使用VBA宏代码来解决，也可以使用Python来解决，这里我们使用VBA宏来实现。

VBA宏的基本思想是：根据指定的列（筛选列）的各个数据项，逐一自动筛选出相应的数据行，然后将这些自动筛选后的数据行复制到新建的、以此数据项命名的工作表中，这样就实现了原始数据表的“拆分”。

假设有如下图所示的Excel工作表，工作表名称为Sheet1：

将此Excel工作簿以“Excel启用宏的工作簿(*.xlsm)”文件类型存盘到电脑上。然后按Alt+F11组合键进入到VBA代码窗口。点击窗口中的“插入\模块"菜单项，进入模块窗口。

我们首先编写一个自定义函数ListUnique，用于列出指定列中不重复的数据项，并存入一个一维数组中，调用此函数将返回一个一维数组。

像本例中，就是给出各“销售门店”，得到一个一维数组：（"朝阳路店","开发区店","新华路店","西直门店") 。在主调程序FilterAndCopy中，根据这些“数据项”在原工作表中依次筛选出相应的数据行，然后逐一将筛选得到的这些行复制到以相应的“数据项”命名的工作表中，相应的VBA代码如下：

代码中调用了VBA中的AutoFilter方法与SpecialCells方法，相当于Excel工作表窗口中的【自动筛选】与【定位条件\可见单元格】。返回Excel工作表窗口后，运行FilterAndCopy宏命令，操作步骤如下图示：

宏代码运行完成后，将自动生成工作表，表中包含筛选得到的相应数据行，如下图示。

下面给出完整的VBA宏代码：

Sub FilterAndCopy()Dim wsSource As WorksheetDim wsTarget As WorksheetDim rngSource As RangeDim rngTarget As RangeDim filterCriteria As VariantDim lastRow As LongApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseApplication.StatusBar = "开始拆分工作表，请稍候..."' 设置源工作表和目标工作表Set wsSource = ThisWorkbook.Worksheets("sheet1")'Set wsTarget = ThisWorkbook.Worksheets.Add' 设置源数据范围lastRow = wsSource.Cells(wsSource.Rows.count, "A").End(xlUp).RowSet rngSource = wsSource.Range("A1:I" & lastRow) '假设数据在A到I列' 设置筛选条件filterCriteria = ListUnique() '根据实际情况修改筛选的列' 循环筛选并复制到目标工作表For Each criteria In filterCriteriaThisWorkbook.Worksheets.Add After:=Sheets(Sheets.count)Set wsTarget = ThisWorkbook.ActiveSheetwsTarget.Name = criteria' 根据实际情况修改筛选的列，这里设为第2列rngSource.AutoFilter Field:=2, Criteria1:=criteriaSet rngTarget = rngSource.SpecialCells(xlCellTypeVisible)rngTarget.Copy wsTarget.Cells(1, 1)rngSource.AutoFilter ' 清除筛选Next criteria' 调整目标工作表的列宽wsTarget.Columns.AutoFitApplication.StatusBar = ""Application.ScreenUpdating = TrueApplication.DisplayAlerts = True' 提示筛选和复制完成MsgBox "操作完成！"End SubFunction ListUnique()'列出B列中不重复的项，存入并返回一个一维数组'根据实际情况修改筛选的列，这里筛选B列Dim rng As RangeDim cell As RangeDim dict As ObjectDim values() As VariantDim count As Integer' 设置一个动态数据字典Set dict = CreateObject("Scripting.Dictionary")' 设置要处理的列范围,筛选列设为B列r = Sheets("Sheet1").Range("B65535").End(xlUp).RowSet rng = ThisWorkbook.Sheets("Sheet1").Range("B2:B" & r)' 遍历指定列的每个单元格For Each cell In rngIf Not dict.Exists(cell.Value) Then' 如果值不在字典中且不为空，则添加到字典dict.Add cell.Value, cell.ValueEnd IfNext cell' 根据字典的大小创建一个数组ReDim values(0 To dict.count - 1)' 将字典的键值复制到数组count = 0For Each Key In dict.Keysvalues(count) = Keycount = count + 1Next Key' 清理Set dict = NothingSet rng = NothingListUnique = values '返回一个一维数组End Function

当然，上述代码也适用于其它按列拆分工作表的情况，仅需将代码中的相关工作表sheet1改为指定名称、B列改为指定的列就可以了（注：这里的列数据类型要求是文本型，不能是日期型、数值型等，如果是其它类型，代码需要作相关改动）。