VBA按关键字拆分表格

除非注明，文章均为战战如疯原创，转载请保留链接: http://www.zhanzhanrufeng.com/cat4/321.html，VBA交流群273624828。

今天来看一个按关键字拆分表格的例子。现在我们手上有一个综合的表，里面有产品编号一项，现在我们要将这张表按产品编号拆分为不同的表，新表以产品编号命名。解题的基本思路是按各个关键字对原表进行筛选，将筛选出来的结果复制到新的表中即可，那怎样将所有不同关键字找出来呢？自然是用字典法了。直接看代码了

Sub chaifen()
Dim r, Arr, d, k, i
Dim rng As Range
Dim sht As Worksheet, Sht1 As Worksheet
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Sht1 = ActiveSheet 'sht1为当前活动工作表
For Each sht In Sheets
If sht.Name <> Sht1.Name Then sht.Delete   '运行程序之前先将多余的工作表删除
Next
On Error Resume Next
r = [a65536].End(xlUp).Row
Arr = Range("a3:h" & r)
For i = 1 To UBound(Arr)
d(Arr(i, 2)) = ""     '通过字典取不重复的订单编号
Next
k = d.keys            '订单编号放入数组k
Set rng = Range("a2:h" & r)   '要拆分的区域
For i = 0 To UBound(k)    '下面按不重复的订单号进行自动筛选
rng.AutoFilter 2, Criteria1:=k(i)      '自动筛选，2表示基准字段是第2列，Criterial是关键字
rng.Copy                  '筛选结果进行复制
Sheets.Add after:=Sheets(Sheets.Count)     '添加一个工作表，放了所以表之后
ActiveSheet.Name = k(i)     '给新加的工作表命名
ActiveSheet.Paste           '把上面复制的内容粘贴
Columns("a:h").AutoFit      '调整单元格宽度为自适应
[a2].Select
Next
rng.AutoFilter          '取消自动筛选
Sht1.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

因为我们要多次调试程序，所以在运行之前要将多余的工作表都删除，用了个for each循环，只要名称不等于当前工作表的都删除掉。下面就用字典法来查找不重复的关键字，这里不多说了，不明白的参考前面的文章“字典精简教程”。下面就是对各个关键字进行筛选了，rng是筛选的区域，这里我们只写了两个参数，2代表以第2列为标准进行筛选，就是我们的关键字列。筛选结果进行复制直接用Copy方法，之后是就是添加新的工作表，将结果复制进去即可。循环直到所有关键字都筛选完成。最后再运行一遍 rng.AutoFilter就取消了自动筛选，否则工作表上还是筛选的形式。

本节示例文件下载：http://pan.baidu.com/s/1eQzQSCE。