如何将表格A列作为项目名称B-D列作为内容，生成多个sheet

cupid1943

由于对vba实在一窍不通，再加上数据信息规模比较庞大。希望哪位好心人能帮忙解决一下这个难题。万分感谢。
P.s. 表格内存在的变量为要分割的列数，列数可能会增多，比如B到Z列。

kuangben8

先上传附件吧，不然怎么帮助你呢？

cupid1943

kuangben8 发表于 2018-9-11 13:29
先上传附件吧，不然怎么帮助你呢？

感谢感谢！

liulang0808

Sub test()
    Application.ScreenUpdating = False
    Set sh = Sheets(1)
    For j = 2 To sh.Cells(2, Columns.Count).End(xlToLeft).Column
        str1 = sh.Cells(3, j)
        Sheets.Add after:=sh
        Sheets(2).Name = str1
        Union(sh.Columns(1), sh.Columns(j)).Copy Sheets(2).[a1]
    Next j
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。。。

cupid1943

liulang0808 发表于 2018-9-11 13:45
附件内容供参考。。。。。。

请问，如果想以表格内合同号明明分割后的sheet应该如何操作

kuangben8

你的表格样式应该转置一下，然后设置自动筛选和窗口冻结，后续透视表或者函数公式就可以简单解决了。 业务情况说明模板.zip (11.27 KB, 下载次数: 1)

2018-9-11 13:51 上传

点击文件名下载附件

liulang0808

cupid1943 发表于 2018-9-11 13:47
请问，如果想以表格内合同号明明分割后的sheet应该如何操作

http://club.excelhome.net/thread-1385473-1-1.html
可以参考第五项，使用字典

cupid1943

liulang0808 发表于 2018-9-11 13:53
http://club.excelhome.net/thread-1385473-1-1.html
可以参考第五项，使用字典

无奈0基础，看了半天实在没太看懂，实在抱歉，给您添麻烦了

Sub test()
    Application.ScreenUpdating = False
    Set sh = Sheets(1)
    For j = 2 To sh.Cells(2, Columns.Count).End(xlToLeft).Column
        str1 = sh.Cells(3, j)
        Sheets.Add after:=sh
        Sheets(2).Name = str1
        Union(sh.Columns(1), sh.Columns(j)).Copy Sheets(2).[a1]
    Next j
    Application.ScreenUpdating = True
End Sub
这段代码中有哪一项是可以直接将分割后的sheet名变更为合同号的代码么？
如果我增加列的话需要变更哪项信息么?

liulang0808

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = Sheets(1)
   
5.     For j = 2 To sh.Cells(2, Columns.Count).End(xlToLeft).Column
   
6.         str1 = sh.Cells(2, j)
   
7.         If d.exists(str1) Then
   
8.             Set d(str1) = Union(d(str1), sh.Columns(j))
   
9.         Else
   
10.             Set d(str1) = Union(sh.Columns(1), sh.Columns(j))
    
11.         End If
    
12.         
    
13.     Next j
    
14.     For j = 0 To d.Count - 1
    
15.         Sheets.Add after:=sh
    
16.         Sheets(2).Name = d.keys()(j)
    
17.         d.items()(j).Copy Sheets(2).[a1]
    
18.     Next j
    
19.     Application.ScreenUpdating = True
    
20. End Sub

复制代码