VBA -- 实现按指定条件拆分工作表的功能

大数据背景下，数据变成了巨大的财富。各种数据库如关系型数据库SQL/Oracle和非关系型数据库MangoDB/Redis等的演化和应用更加丰富；同时数据分析从数据采集、数据预处理到数据集成、数据挖掘的需求也更大。从数据采集到数据挖掘，最终服务企业运营，是一条完整和严谨的数据分析流程。在完成高大上的数据挖掘之前，数据采集、预处理到数据集成是不容忽视的基础工作，也是十分繁琐和费时的过程。

现在，许多企业中有大批工作人员工作内容与数据分析的前三个工作流程密切相关，常用软件是Microsoft Excel。日常摆脱不了“表”的纠缠而加班，可能是许多上班族同仁的痛点吧。

个人因兴趣而开此公众号，借此发一些数据分析理论基础/软件操作/编程等的方法或心得，希望能对人对已有所帮助。作为引子，先发一篇VBA按条件拆分工作表的方法，希望有所帮助。

作为例子，创建一个名为“ALL”的工作表，存放了13位不同年龄、不同部门的员工名单。字段包括员工号/姓名/部门和年龄。

现要求按照部门，将十三位员工拆分至所属部门的工作表中。实现功能的VBA代码如下：

（1）新建以部门名称命名的工作表，代码如下：

Sub SplitByDept()

'定义k,b为整数

Dim k%,b%

Sheets(1).Activate

'停止页面刷新，减少内存占用

Application.ScreenUpdating = False

'在列表最后一列后取全部部门名称（工具列）

Range("E2:E14").Value = Range("C2:C14").Value

'工具列去除重复项

Range("E2:E14").RemoveDuplicates 1

'根据部门数量，新建工作表并以部门名称命名

For k = 2 To 6
    a = Sheets(1).Range("E" & k).Value

    b = Sheets.Count

    Sheets.Add after:=Sheets(b)
    Sheets(b+1).Name = a

    '将ALL工作表表头取至新工作表

    Sheets(b+1).Range("A1:D1").Value = _
     Range("A1:D1").Value

Next

'清除工具列数据

Range("E2:E14").ClearContents
Application.ScreenUpdating = True
End Sub

（2）将员工分配至所属部门工作表，代码如下：

Sub MoveEmployeesToDept()
Application.ScreenUpdating = False
'全部员工信息写入数组
arr = Range("A2:D14").Value
'获取数组最大索引
a = UBound(arr)
'循环检查员工部门与工具列部门信息
For i = 1 To a
    For j = 2 To 6
        If arr(i, 3) = Range("E" & j) Then
            With Sheets(j)
            x = .Range("A10").End(xlUp).Row
                '部门信息一致的写入对应工作表
                For k = 1 To 4
                    .Cells(x + 1, k) = arr(i, k)
                Next
            End With
        End If
    Next
Next
'清除工具列数据
Range("E2:E14").ClearContents
Application.ScreenUpdating = True
Erase arr

Thisworkbook.Save

End Sub

以上两部门代码实现了将员工总表按照所属部门进行拆分的功能。实现结果如下图：

本文介绍了通过VBA拆分工作表的方法，也抛出了个人公众号的“VBA引子”。VBA语言比较简单易懂，而且对实际工作有很大的帮助，后期文章将根据情况介绍VBA基础及其他高阶的应用。另外下一个“引子”打算抛出python爬虫，后期也将继续更新python基础、python各种库的调用，以及tableau画图软件的应用等。

欢迎大家关注本人微信公众号，公众号将持续更新python,tableau,SQL等数据分析的文章。

ID: DataDreamInitiate

      公众号名称： 数据分析X小硕