分拆工作簿时如何保留两行标题？

snoopyball

以前有位大大放出了一个分拆模板，非常好用。但是最近遇到个问题，这个模板分行后会保留原来的一行标题，但是如果我的表格有两行标题（如附件所示），请问如何在分拆出来那些工作簿仍然保留这两行标题？请帮忙指出应该修改哪句代码？谢谢！

zhaogang1960

请参考：

1. Sub Macro1()
   
2.     Dim arr, rng As Range, d As Object, k, t, i&, lc%, sh As Worksheet, ICol%, shp As Shape
   
3.     ICol = Application.InputBox("请输入你所要分的列：（如按B列分请输入2）", "提示：", "2", Type:=1)
   
4.     If ICol = 0 Then Exit Sub
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     For Each sh In Sheets
   
8.         If sh.Name <> "总表" Then sh.Delete
   
9.     Next
   
10.     arr = Range("a1").CurrentRegion
    
11.     lc = UBound(arr, 2)
    
12.     Set rng = Rows(1)
    
13.     Set d = CreateObject("scripting.dictionary")
    
14.     For i = 3 To UBound(arr)
    
15.         If Not d.Exists(arr(i, ICol)) Then
    
16.             Set d(arr(i, ICol)) = Cells(i, 1).Resize(1, lc)
    
17.         Else
    
18.             Set d(arr(i, ICol)) = Union(d(arr(i, ICol)), Cells(i, 1).Resize(1, lc))
    
19.         End If
    
20.     Next
    
21.     k = d.Keys
    
22.     t = d.Items
    
23.     For i = 0 To d.Count - 1
    
24.         Sheets("总表").Copy After:=Sheets(Sheets.Count)
    
25.         With ActiveSheet
    
26.             For Each shp In .Shapes
    
27.                 shp.Delete
    
28.             Next
    
29.             .Name = k(i)
    
30.             .UsedRange.Offset(2).Clear
    
31.             t(i).Copy .[a3]
    
32.         End With
    
33.     Next
    
34.     Sheets("总表").Activate
    
35.     Application.DisplayAlerts = True
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    

复制代码

zhaogang1960

请测试附件
分拆模板（空白）-T.rar (29.73 KB, 下载次数: 89)

2014-2-18 16:34 上传

点击文件名下载附件

snoopyball

zhaogang1960 发表于 2014-2-18 16:34
请测试附件

谢谢，可以保留两行标题了。我忘了说明了，我想要表外分表，即分拆成多个工作簿...
或者说原代码修改哪个地方可以实现？

zhaogang1960

snoopyball 发表于 2014-2-18 20:58
谢谢，可以保留两行标题了。我忘了说明了，我想要表外分表，即分拆成多个工作簿...
或者说原代码修改哪个 ...

使用窗体比较好实现：

zhaogang1960

窗体代码：

1. Private Sub CommandButton2_Click() '退出窗体
   
2.     Unload Me
   
3. End Sub
   
4. 
   
5. Private Sub UserForm_Initialize()
   
6.     Dim i&, arr(), lc&
   
7.     lc = ActiveSheet.UsedRange.Columns.Count
   
8.     ReDim arr(1 To lc)
   
9.     For i = 1 To lc
   
10.         arr(i) = i
    
11.     Next
    
12.     With ComboBox1
    
13.         .List = Array(1, 2, 3, 4, 5)
    
14.         .ListIndex = 1 '默认2行表头
    
15.     End With
    
16.     With ComboBox2
    
17.         .List = arr
    
18.         .ListIndex = 1 '默认拆分第二列
    
19.     End With
    
20. End Sub
    
21. 
    

复制代码

zhaogang1960

拆分代码：

1.     If ComboBox1.ListIndex = -1 Or ComboBox2.ListIndex = -1 Then Exit Sub
   
2.     Dim sh As Worksheet, sht As Worksheet, arr, s$, i&, k, t, lr&, lc&
   
3.     lr = Range("A65536").End(xlUp).Row - 1
   
4.     lc = ActiveSheet.UsedRange.Columns.Count
   
5.     arr = [a1].Resize(lr, lc)
   
6.     fr = ComboBox1.ListIndex + 2
   
7.     c = ComboBox2.ListIndex + 1
   
8.     Application.ScreenUpdating = False
   
9.     Application.DisplayAlerts = False
   
10. 
    
11.     With CreateObject("scripting.dictionary")
    
12.         For i = fr To UBound(arr)
    
13.             s = arr(i, c)
    
14.             If Not .Exists(s) Then .Add s, Cells(i, 1).Resize(1, lc) Else Set .Item(s) = Union(.Item(s), Cells(i, 1).Resize(1, lc))
    
15.         Next i
    
16.         k = .keys
    
17.         t = .Items
    
18.     End With
    
19.     Set sht = Sheets("总表")
    
20.     If CheckBox1.Value Then
    
21.         For i = 0 To UBound(k)
    
22.             sht.Copy
    
23.             With ActiveSheet
    
24.                 For Each shp In .Shapes
    
25.                     shp.Delete
    
26.                 Next
    
27.                 .Name = k(i)
    
28.                 .UsedRange.Offset(fr - 1).Clear
    
29.                 t(i).Copy .Cells(fr, 1)
    
30.             End With
    
31.             ActiveWorkbook.Close True, ThisWorkbook.Path & "" & k(i) & ".xls"
    
32.         Next
    
33.     Else
    
34.         For Each sh In Sheets
    
35.             If sh.Name <> "总表" Then sh.Delete
    
36.         Next
    
37.         For i = 0 To UBound(k)
    
38.             sht.Copy After:=Sheets(Sheets.Count)
    
39.             With ActiveSheet
    
40.                 For Each shp In .Shapes
    
41.                     shp.Delete
    
42.                 Next
    
43.                 .Name = k(i)
    
44.                 .UsedRange.Offset(fr - 1).Clear
    
45.                 t(i).Copy .Cells(fr, 1)
    
46.             End With
    
47.         Next
    
48.         sht.Activate
    
49.     End If
    
50.     Unload Me
    
51.     Application.ScreenUpdating = True
    
52. End Sub

复制代码

zhaogang1960

请测试附件
分拆模板（空白）-T.rar (35.26 KB, 下载次数: 167)

2014-2-18 21:34 上传

点击文件名下载附件

snoopyball

zhaogang1960 发表于 2014-2-18 21:35
请测试附件

这个窗体的构想真的不错；完全是我想要的效果，谢谢！
代码还有待慢慢消化...

snoopyball

zhaogang1960 发表于 2014-2-18 21:35
请测试附件

请问大神怎么给拆分的工作簿用代码实现自动加密码，用了ActiveWorkbook.Password = "1234"和ThisWorkbook.Password = "1234"都不成功，不知道是不是代码放错地方，谢谢。