1.需求范例
公司发放奖金,仅在部门内部公示,需要将奖金发放表按部门分隔为若干个分表,分别发给各部门。表格小了还好办,手动选择、复制、粘贴、另存一遍即可解决,如果表格大、部门多、数据未按部门排序的话,手动处理工作量就会很大,通过VBA可以一键完成。例如下表:
2.基本思路
对作为拆分依据的列建立一个字典,逐行遍历表格,若当前行的“部门”已在字典中存在,则将属于同一部门的数据连接起来;若字典中不存在,则在字典中添加成员项。根据字典中项目新建表格并以项目命名,将同一部门的数据复制到对应表格中。
3.VBA实现
Option Explicit
Sub 按列拆分工作表()
Dim Arr, Rng As Range, Sht As Worksheet, Dic As Object
Dim k, t, Str As String, i As Long, lc As Long
'关闭屏幕更新
Application.ScreenUpdating = False
Arr = Range("A1").CurrentRegion.value
'求取最后一列的列号
lc = UBound(Arr, 2)
'标题行
Set Rng = Rows(1)
'创建字典
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
'拆分依据列号,关键字,如果要换列,改这个数字即可,本例“部门”在E列,即第5列
Str = Arr(i, 5)
'如果字典没有关键字
If Not Dic.Exists(Str) Then
'把当前行装入到字典中
Set Dic(Str) = Cells(i, 1).Resize(, lc)
Else '否则(字典中存在关键字)
'把行连合起来
Set Dic(Str) = Union(Dic(Str), Cells(i, 1).Resize(, lc))
End If
Next
'字典关键字集合
k = Dic.Keys
'字典项目集合
t = Dic.Items
On Error Resume Next
With Sheets
'循环关键字的个数
For i = 0 To Dic.Count - 1
'给变量赋值(工作表名为关键字)
Set Sht = .Item(k(i))
'该工作表不存在则插入一个空工作表
If Sht Is Nothing Then
'新建的工作表将置于所有工作表之后,并命名为关键字
.Add(After:=.Item(.Count)).Name = k(i)
'活动工作表给变量
Set Sht = ActiveSheet
'否则
Else
'清除工作中所有内容和格式
Sht.Cells.Clear
End If
'把标题写入第一行
Rng.Copy Sht.Range("A1")
'写入其他内容
t(i).Copy Sht.Range("A2")
'自动调整全工作表单元格的列宽
Sht.Cells.EntireColumn.AutoFit
'变量处于初始状态
Set Sht = Nothing
Next
End With
'第1个工作表处于激活状态
Sheets(1).Activate
'打开屏幕更新
Application.ScreenUpdating = True
End Sub