求助大神宏解决问题

liuqiang_75

求助：       
将表1中按C列部门编码按以下规则进行对应，部门取前4位，对应下面规则，然后按部门规则复制粘贴出来生成新的SHEET表，名称用对应出来的名称命名。       
       
后面三个A部门，B部门，C部门的SHEET表是用复制粘贴出来的结果，效率太慢，求助宏的方法       

yeminqiang

透视表啊.......

liuqiang_75

yeminqiang 发表于 2017-5-28 18:24
透视表啊.......

透视表那个还不如先用个VLOOKUP，然后筛选粘贴，透视表也解决不了根据部门编码归类部门大类的问题。

qingc0221

liuqiang_75 发表于 2017-5-28 21:23
透视表那个还不如先用个VLOOKUP，然后筛选粘贴，透视表也解决不了根据部门编码归类部门大类的问题。

加个辅助列来放部门编码前四位就行了

liuqiang_75

qingc0221 发表于 2017-5-28 21:44
加个辅助列来放部门编码前四位就行了

透视表也只限在一个工作簿里增加SHEET表，而VBA可以新建工作簿。优势挺多。
而且这个表并没有改变列的顺序，感觉用透视表并不方便

lsc900707

代码放“表1”工作表代码区，按钮用activex按钮

1. Private Sub CommandButton1_Click()
   
2.     tim1 = Timer
   
3.     Application.DisplayAlerts = False
   
4.     For Each sht In Sheets
   
5.         If sht.Name <> "表1" Then sht.Delete
   
6.     Next
   
7.     Application.DisplayAlerts = True
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     arr = [a1].CurrentRegion
   
10.     For i = 1 To UBound(arr)
    
11.         For j = 1 To UBound(arr, 2)
    
12.             s = Left(arr(i, 3), 1)
    
13.             If Not d.exists(s) Then
    
14.                  Set d(s) = Range("a" & i).Resize(1, j)
    
15.             Else
    
16.                  Set d(s) = Union(d(s), Range("a" & i).Resize(1, j))
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     x = d.keys
    
21.     For k = 1 To UBound(x)
    
22.         Set sht = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
    
23.         sht.Name = x(k) & "部门"
    
24.         d.items()(k).Copy sht.[a2]
    
25.         Rows("1").Copy sht.[a1]
    
26.     Next
    
27.     tim2 = Timer
    
28.     MsgBox Format(tim2 - tim1, "拆分完成，共耗时：0.00秒"), 64, "时间统计"
    
29. End Sub

复制代码

liuqiang_75

lsc900707 发表于 2017-5-28 23:07
代码放“表1”工作表代码区，按钮用activex按钮

多谢，经测算，OK!多谢
嘿嘿，只是完全看不懂，想复制到其他的表格做差不多类似的，完全不知道怎么改些内容。哪怕是换一列都不知道从哪修改。

lsc900707

代码只能根据数据来写的。自己不会改，那就发真实一点的附件上来。

liuqiang_75

lsc900707 发表于 2017-5-30 05:38
代码只能根据数据来写的。自己不会改，那就发真实一点的附件上来。

多谢了。。再帮着弄一个哈