自动拆分表格问题

寻梅笑梦

zhaogang1960 发表于 2012-8-2 17:17
如果有该部门工作表，则清空内容，如果没有则在最右边插入一个工作表，并命名为该部门
请看附件

版主，想问一下，就在这个工作簿中，要是我还想要个拆分类别的明细，比如再拆分一个“客户类别”，能实现吗？拆分出来的工作表就放在sheet1表的左边

zhaogang1960

寻梅笑梦 发表于 2012-8-7 14:53
版主，想问一下，就在这个工作簿中，要是我还想要个拆分类别的明细，比如再拆分一个“客户类别”，能实现 ...

我已经忘记这个帖子了，请说明你看上几楼代码了，请上传附件说明要求

寻梅笑梦

版主，我看的是15楼的帖子。

当时帖子中是只能在第一列进项拆分。

现在我像问的是能不能在任意一列或多列进行拆分？拆分出来的工作表中字体能不能默认为10字体。我们弄了半天也不会。
{:soso_e132:}

zhaogang1960

寻梅笑梦 发表于 2012-8-14 16:16
版主，我看的是15楼的帖子。

当时帖子中是只能在第一列进项拆分。

拆分为几个工作表(窗体).rar (20.71 KB, 下载次数: 162)

2012-8-14 16:38 上传

点击文件名下载附件

寻梅笑梦

zhaogang1960 发表于 2012-8-14 16:38

太感谢了，版主，你真是太厉害了。灰常感谢啊！

润润洁

zhaogang1960 发表于 2012-6-8 10:30
下载到哪里了？请看演示：

你好，
请问生成的新excel表怎么保持和原表的格式字体一致？

zhaogang1960

润润洁 发表于 2012-8-24 16:25
你好，
请问生成的新excel表怎么保持和原表的格式字体一致？

应该说基本一致了：
1、使用复制数据行
2、直接复制原表生成新表
请使用25楼附件试试看

学生甲1

好代码，学习了。

zhaogang1960

请看附件
拆分为几个工作表(窗体).rar (21.31 KB, 下载次数: 105)

2012-8-27 16:01 上传

点击文件名下载附件

zhaogang1960

润润洁 发表于 2012-8-27 14:44
谢谢你的回复，我想生成的是新的excel表，并且保持格式字体都和原来的excel一致，那个模板里是生成新的sh ...

生成新工作簿:

1. Private Sub CommandButton1_Click()
   
2.     If ComboBox1.ListIndex = -1 Or ComboBox2.ListIndex = -1 Then Exit Sub
   
3.     Dim sh As Worksheet, arr, s$, i&, k, t, lr&, d As Object, lc&, shn$
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set sh = ActiveSheet
   
8.     lr = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
   
9.     lc = sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1
   
10.     arr = [a1].Resize(lr, lc)
    
11.     fr = ComboBox1.ListIndex + 2
    
12.     c = ComboBox2.ListIndex + 1
    
13.     With CreateObject("scripting.dictionary")
    
14.         For i = fr To UBound(arr)
    
15.             s = arr(i, c)
    
16.             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))
    
17.             d(s) = d(s) + 1
    
18.         Next i
    
19.         k = .keys
    
20.         t = .Items
    
21.         t2 = d.Items
    
22.     End With
    
23.     For i = 0 To UBound(k)
    
24.         sh.Copy
    
25.         With ActiveSheet
    
26.             .Name = k(i)
    
27.             .Rows(t2(i) + fr & ":" & lr).Delete Shift:=xlUp
    
28.             t(i).Copy .Cells(fr, 1)
    
29.         End With
    
30.         ActiveWorkbook.Close True, ThisWorkbook.Path & "" & k(i) & ".xls"
    
31.     Next
    
32.     Unload Me
    
33.     Application.DisplayAlerts = True
    
34.     Application.ScreenUpdating = True
    
35. End Sub

复制代码