【跪求高手帮忙】按照指定格式拆分多个表格

静子I

	因为表格实在很多，而且分公司及产品也很多，本表只是列举了其中的部分，一个一个手工复制粘贴一天都干不完，跪求高手帮助。
1、	拆分的底表有很多个sheet，但是只需要拆分表格中的《明细-Dec》、《明细-Q3》两张sheet，其它的sheet不需要体现在拆分后的表格中
2、	达成率和排名需要全部显示，但是实际的目标和达成数据只显示相应的分公司的
3、	拆分后的表格样式与底表保持一致，工作薄名称和底表的一致
4、	拆分后的表格直接以分公司的名称加表头命名，如：A-Dec销售达成表

不好意思，刚才把要拆分的底表放错了，应该以这个为准。
附件已经上传！还请高手们指点指点~
A-Dec销售报表.zip (860.81 KB, 下载次数: 21)

2015-2-26 10:33 上传

点击文件名下载附件

Dec销售报表.zip (880.66 KB, 下载次数: 14)

2015-2-26 10:33 上传

点击文件名下载附件

补充内容 (2015-3-3 18:47):
版主您好！我研究了几天还是不大明白其中的一些语句，比如我的表格改变了格式，那我要相应的改哪些地方呢？还请指教，改格式后的表格请见附件！感谢感谢！附件在9楼~

静子I

跪求高手帮忙！小妹在此先谢过啦！并祝新年快乐~

静子I

高手呀高手~~速来呀~

chenbiao2012

看了半天愣是没看明白

chenbiao2012

你得把需要达到的目标说清楚，最好用备注标明，这样别人也好帮你

静子I

我的附件里面有呀！《A-Dec销售报表》这张表就是我希望达到效果~高手，你再看看~

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Sht As Worksheet, nm$, nm1$, m&, n&
   
3. Dim d, k, t, j&, y&
   
4. Application.ScreenUpdating = False
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. nm = ThisWorkbook.Name
   
7. Sheets("明细-Dec").Activate
   
8. Arr = [c5].CurrentRegion
   
9. For i = 3 To UBound(Arr) - 1
   
10.     d(Arr(i, 1)) = i + 4
    
11. Next
    
12. k = d.keys: t = d.items
    
13. For i = 0 To UBound(k)
    
14.     nm1 = k(i) & "-" & nm
    
15.     Sheets(Array("明细-Dec", "明细-Q3")).Copy
    
16.     With ActiveWorkbook
    
17.         For Each Sht In .Sheets
    
18.             With Sht
    
19.                 .Activate
    
20.                 .[c2] = k(i) & "-" & .[c2].Value
    
21.                 For j = 0 To UBound(t)
    
22.                     If i <> j Then
    
23.                         m = t(j): n = m + 14
    
24.                         For y = 5 To 50 Step 9
    
25.                             .Cells(m, y).Resize(1, 3) = ""
    
26.                             .Cells(m, y + 7) = ""
    
27.                             .Cells(n, y).Resize(1, 3) = ""
    
28.                             .Cells(n, y + 7) = ""
    
29.                         Next
    
30.                     End If
    
31.                 Next
    
32.             End With
    
33.         Next
    
34.         .SaveAs ThisWorkbook.Path & "" & nm1
    
35.         .Close
    
36.     End With
    
37. Next
    
38. Application.ScreenUpdating = True
    
39. End Sub
    

复制代码

蓝桥玄霜

请见附件。

静子I

版主您好！我研究了几天还是不大明白其中的一些语句，比如我的表格改变了格式，那我要相应的改哪些地方呢？还请指教，改格式后的表格请见附件！感谢感谢！
Dec销售报表-更改格式后.zip (895.98 KB, 下载次数: 5)

2015-3-3 18:34 上传

点击文件名下载附件

静子I

版主呀！版主~~速来帮忙哟~