[已解决]VBA拆分工作表

rainbowsjh

见附件 希望按照A列将工作表拆成BJ SH CQ HZ 四个工作薄，每个工作薄就是一张sheet，内容 Index.rar (23.12 KB, 下载次数: 21)

2013-5-21 21:57 上传

点击文件名下载附件

就是sheet test里按A列筛选出的内容 谢谢高手帮忙 貌似只能用VBA了吧

最佳答案

月排行榜 / 总排行榜

ligh1298

2013-5-21 22:18

楼主：是不是想要这样的？见附件！

1. Sub 工作薄总表拆分多工作表()
   
2. Dim r%, j%, rng As Range, rngs As Range, sht As Worksheet, d As Object
   
3. Application.DisplayAlerts = False '禁止弹出对话框
   
4. Application.ScreenUpdating = False '屏蔽屏幕刷新
   
5. Set zbst = Sheets("test") '以下可用zbst替代Sheets("sest")
   
6. Set d = CreateObject("scripting.dictionary") '字典
   
7. For Each rng In Range("a2:a" & zbst.[a65536].End(3).Row) 'rng遍历a列第2行及以下有数据单元格
   
8. If Not d.exists(rng.Value) Then d.Add (rng.Value), Nothing 'a列第2行及以下数据去重复
   
9. Next
   
10. k5 = d.keys
    
11. 
    
12. For Each sht In Sheets '遍历此薄下的所有工作表
    
13. If sht.Name <> "test" Then sht.Delete '删除不是“test”的其他表格
    
14. Next
    
15. 
    
16. 
    
17. For Each na In d.keys '遍历字典里的内容
    
18. Sheets.Add(, zbst).Name = na '新建字典中储存内容为名字的工作表
    
19. zbst.Activate
    
20. zbst.[a1:g1].Copy Sheets(na).[a1:g1] '复制标题
    
21. For Each rangs In zbst.Range("a2:e" & zbst.[a65536].End(3).Row) 'rangs遍历a列第2行及以下有数据单元格
    
22. If rangs.Value = na Then '如果rangs等于，就……
    
23. r = r + 1 '计数，为下面写入单元格中数据时，行变化
    
24. For j = 1 To 7 '为下面写入单元格中数据时，列变化
    
25. Sheets(na).Cells(r + 1, 8 - j) = zbst.Cells(rangs.Row, 8 - j) '把满足条件数据写入表中
    
26. Next
    
27. End If
    
28. 
    
29. 
    
30. Next
    
31. 
    
32. 
    
33. r = 0 '为的是重新计数，满足条件的数据都能写入新表第二行
    
34. Next
    
35. Application.DisplayAlerts = True '恢复弹出对话框
    
36. Application.ScreenUpdating = True '屏幕刷新
    
37. MsgBox "总表拆分完成！", 64 '弹出总表拆分完成！对话框
    
38. End Sub
    

复制代码

跳转到最佳答案楼层

ligh1298

楼主：是不是想要这样的？见附件！

1. Sub 工作薄总表拆分多工作表()
   
2. Dim r%, j%, rng As Range, rngs As Range, sht As Worksheet, d As Object
   
3. Application.DisplayAlerts = False '禁止弹出对话框
   
4. Application.ScreenUpdating = False '屏蔽屏幕刷新
   
5. Set zbst = Sheets("test") '以下可用zbst替代Sheets("sest")
   
6. Set d = CreateObject("scripting.dictionary") '字典
   
7. For Each rng In Range("a2:a" & zbst.[a65536].End(3).Row) 'rng遍历a列第2行及以下有数据单元格
   
8. If Not d.exists(rng.Value) Then d.Add (rng.Value), Nothing 'a列第2行及以下数据去重复
   
9. Next
   
10. k5 = d.keys
    
11. 
    
12. For Each sht In Sheets '遍历此薄下的所有工作表
    
13. If sht.Name <> "test" Then sht.Delete '删除不是“test”的其他表格
    
14. Next
    
15. 
    
16. 
    
17. For Each na In d.keys '遍历字典里的内容
    
18. Sheets.Add(, zbst).Name = na '新建字典中储存内容为名字的工作表
    
19. zbst.Activate
    
20. zbst.[a1:g1].Copy Sheets(na).[a1:g1] '复制标题
    
21. For Each rangs In zbst.Range("a2:e" & zbst.[a65536].End(3).Row) 'rangs遍历a列第2行及以下有数据单元格
    
22. If rangs.Value = na Then '如果rangs等于，就……
    
23. r = r + 1 '计数，为下面写入单元格中数据时，行变化
    
24. For j = 1 To 7 '为下面写入单元格中数据时，列变化
    
25. Sheets(na).Cells(r + 1, 8 - j) = zbst.Cells(rangs.Row, 8 - j) '把满足条件数据写入表中
    
26. Next
    
27. End If
    
28. 
    
29. 
    
30. Next
    
31. 
    
32. 
    
33. r = 0 '为的是重新计数，满足条件的数据都能写入新表第二行
    
34. Next
    
35. Application.DisplayAlerts = True '恢复弹出对话框
    
36. Application.ScreenUpdating = True '屏幕刷新
    
37. MsgBox "总表拆分完成！", 64 '弹出总表拆分完成！对话框
    
38. End Sub
    

复制代码

rainbowsjh

ligh1298 发表于 2013-5-21 22:18
楼主：是不是想要这样的？见附件！

谢谢老师！ 工作表的内容是对了 可是我是想拆成四个工作薄不是工作表 怎么解决呢

木牙水

代码写的很详细，今天正要解决一个拆分的问题