真爱剧场 之拆分工作表

风哥哥 我又来了啦！~~~~

---

又要干啥？

---

不要怕嘛！还不是都怪你 上次给我什么大搬运， 领导看见之后 感觉效率上去了，现在又让我把合并后的数据，根据产品名称拆分成单个工作表。喏，就是这样的。

---

领导一定是疯了！！！！！

---

风哥哥你就帮帮人家嘛！~~ 还有哦：我要操作越简单越好，经常会拆表的。

---

先说数据透视表的方法

第一步：选择你的数据

第二步：插入---数据透视表

第三步：将需要的字段 拖到行标签

第四步：将产品名称拖到报表筛选

第五步：设置报表布局--表格形式显示

第六步：生成报表筛选页

---

注意只有选择了透视表，才会出现

【数据透视表工具】选项卡

---

那就是说 我每次拆表 都要操作一次咯？人家不要嘛！~~ 人家还要上次那种大搬运的，多方便。

---

好难伺候啊！！！等着！

Sub 拆分工作表()

Dim sht As Worksheet, rng As Range, i As Integer, mysht As Worksheet

On Error Resume Next

i = Sheets('汇总').Cells(Rows.Count, 1).End(xlUp).Row

For Each rng In Sheets('汇总').Range('b2:b' & i)

Set sht = Worksheets(rng.Value)

If sht Is Nothing Then

Set sht = Worksheets.Add

sht.Name = rng.Value

End If

If InStr(mystr, rng) = 0 Then

With Sheets('汇总')

.Select

.UsedRange.AutoFilter Field:=2, Criteria1:=rng

.UsedRange.SpecialCells(xlCellTypeVisible).Select

Selection.Copy sht.Range('a1')

mystr = mystr & sht.Name

End With

End If

Set sht = Nothing

Next

Sheets('汇总').UsedRange.AutoFilter

End Sub

---

风哥哥好腻害！~~接下来是不是这样：

首先 在工作表里 按下<ALT+F11>进入VBE界面，菜单里找到【插入】，【模块】，然后将上边的代码复制进去？

---

女神威武！！！！！

---

是不是酱紫的？

---

我要和你一起吃早餐啊！！

---

代码啥意思啊，快把解释发过来，否则不跟你吃饭了。

---

好嘞！马上送到

Sub 拆分工作表()

' ↑↑↑ 大搬运程序开始

Dim sht As Worksheet

' ↑↑↑ 请个临时工 用来表示拆分后的工作表

Dim rng As Range

' ↑↑↑ 请个临时工 用来表示正在拆分的数据

On Error Resume Next

' ↑↑↑ 容个错 如果工作表已经存在 不提示错误 继续搬

i = Sheets('汇总').Cells(Rows.Count, 1).End(xlUp).Row

' ↑↑↑ 用i表示待拆分的数据条目数

For Each rng In Sheets('汇总').Range('b2:b' & i)

' ↑↑↑ 让临时工rng依次表示正在拆分的数据

Set sht = Worksheets(rng.Value)

' ↑↑↑ 用临时工sht表示将数据拆分到的目标工作表工作表

If sht Is Nothing Then

' ↑↑↑ 如果目标工作表工作表不存在 那么

Set sht = Worksheets.Add

' ↑↑↑ 新建一个工作表 仍然用临时工sht表示

sht.Name = rng.Value

' ↑↑↑ 以正在拆的数据命名

End If

If InStr(mystr, rng) = 0 Then

' ↑↑↑ 判断这个数据拆过没有 如果没拆过就开始拆，如果已经拆过 就不管了

With Sheets('汇总')

' ↑↑↑ 开始操作《汇总》工作表

.Select

' ↑↑↑ 选中汇总表

.UsedRange.AutoFilter Field:=2, Criteria1:=rng

' ↑↑↑ 筛选汇总表 的第二列中为当前拆的数据的所有条目

.UsedRange.SpecialCells(xlCellTypeVisible).Select

' ↑↑↑ 选中筛选后的结果

Selection.Copy sht.Range('a1')

' ↑↑↑ 将筛选后的结果复制到 目标工作表

mystr = mystr & sht.Name

' ↑↑↑ 记录已经拆分的数据名称

End With

End If

Set sht = Nothing

' ↑↑↑ 搬完之后 把数据放下

Next

Sheets('汇总').UsedRange.AutoFilter

' ↑↑↑ 取消筛选

End Sub

---

谢谢，明白了我去洗澡了

---

别忘了存成启用宏的文件（xls、xlsm）！

还有啊，记得带肥皂……

作者：随风 友情客串：看见星光

回复数字 00，获取往期精彩推荐。

回复300，获取300集易学宝微视频课程详情。

点击【阅读原文】直达官方淘宝店自助下单。