怎么样根据某列的关键字把源数据表整行数据拆分到分表

hanse1212

由于工作需要， 要将“责任单位”的各个单位分别拆拆，制出分表（sheet），其他要素不变，如“审核结果、序号、交办时间”之类的要素不变，就是整行数据都复制到新表去，具体效果就变成第二张图那样子，

在坛子搜索过类似的，不过是针对工资条，不懂得怎么调整，请大神指点一二。


分表的时候要把标题那几行都要复制过去，还有能不能自定义复制到分表的标题头从第几行到第几行的，像我这个表的表头就要占了4行了

1111.zip (6.79 KB, 下载次数: 9)

2018-7-30 17:02 上传

点击文件名下载附件

格子人生

我用金山WPS表格中的【拆分表格】先要在选项对话框中勾选对应选项
然后对表格设置自动筛选，它就会自动多一个工具栏，里面就有【拆分表格】的功能

hanse1212

格子人生 发表于 2018-7-30 17:22
我用金山WPS表格中的【拆分表格】先要在选项对话框中勾选对应选项
然后对表格设置自动筛选，它就会自动多 ...

谢谢帮助，效果都一样，不过不大想为了一个效果装多另一个软件，而且你这个是限免的？

不知道为什么

就一工作表拆分，可以用字典来做

lsc900707

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

复制代码

lsc900707

附件供测试：

不知道为什么

如图

不知道为什么

格子人生 发表于 2018-7-30 17:22
我用金山WPS表格中的【拆分表格】先要在选项对话框中勾选对应选项
然后对表格设置自动筛选，它就会自动多 ...

刚是不是服务器宕了，现在终于好了

jiminyanyan

一搜一大把。。。

hanse1212

lsc900707 发表于 2018-7-30 17:51
附件供测试：

  Set d = CreateObject("scripting.dictionary")    arr = [a1].CurrentRegion
运行的时候，这一条出错