求一个拆分与合并工作表的代码

星语心愿

求一个拆分与合并工作表的代码.rar (302.62 KB, 下载次数: 132)

2011-12-18 02:10 上传

点击文件名下载附件

　　现在我的学生花名册是所有学校班级的学生信息都保存到一张工作表里面。希望拆分出去供各学校各班的班主任修改，然后再汇总，因为每个学期都有很大的变动。所以希望朋友们帮我写一个拆分工作表与汇总的代码。
1.　根据G列的学校名称拆分成不同的学校，保存到同一个文件夹里面再汇总，不同工作薄的名称就是学校名称。
2.　根据G列的学校名称和H列的年级和I列的班级拆分成不同的学校，保存到同一个文件夹里面再汇总，不同工作薄的名称就是学校名称+年级+班级。

我在论坛里面搜索了一整天，都找不到适合我的要求的模板，所以希望朋友们帮帮我，谢谢了。

AVEL

1. Option Explicit
   
2. 
   
3. Sub l()
   
4.     Dim arr As Variant, brr() As Variant
   
5.     Dim d As Object
   
6.     Dim i As Integer
   
7.     Dim j As Integer, k As Integer, n As Integer
   
8.     Dim a As Variant, b As Variant, c As Variant
   
9.     Dim rng As Range, bb As Integer
   
10.     Dim tmp As String
    
11.     Application.ScreenUpdating = False
    
12.     Application.DisplayAlerts = False
    
13.     Set rng = Sheet3.Range("a1:q1")
    
14.     arr = Sheet3.Range("a1").CurrentRegion
    
15.     Set d = CreateObject("scripting.dictionary")
    
16.     bb = Application.InputBox("请选择：" & vbCrLf & "1、按学校拆分；" & vbCrLf & "2、按学校、年级、班级拆分", "选择拆分类型")
    
17.     For i = 2 To UBound(arr)
    
18.         If bb = 1 Then tmp = arr(i, 7) Else tmp = arr(i, 7) & arr(i, 8) & "年级" & arr(i, 9) & "班"
    
19.         d(tmp) = d(tmp) & "," & i
    
20.     Next
    
21.     a = d.keys
    
22.     b = d.items
    
23.     For i = 0 To UBound(a)
    
24.         ReDim brr(1 To 10000, 1 To 17)
    
25.         c = Split(Mid(b(i), 2), ",")
    
26.         n = 0
    
27.         For j = 0 To UBound(c)
    
28.             n = n + 1
    
29.             For k = 1 To 17
    
30.                 brr(n, k) = arr(c(j), k)
    
31.             Next
    
32.         Next
    
33.         Workbooks.Add
    
34.         With ActiveSheet
    
35.             rng.Copy .Range("a1")
    
36.             .Range("a1").CurrentRegion.Offset(1).Clear
    
37.             .Range("a2").Resize(n, 17).Value = brr
    
38.             .Range("e:e").NumberFormatLocal = "yyyy-mm-dd"
    
39.             .Range("p:p").NumberFormatLocal = "000000"
    
40.         End With
    
41.         ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & a(i) & ".xls"
    
42.         ActiveWorkbook.Close True
    
43.     Next
    
44.     Set d = Nothing
    
45.     Application.ScreenUpdating = True
    
46.     Application.DisplayAlerts = True
    
47. End Sub

复制代码

AVEL

试试。
岔河镇中心校2011年秋季学期人数总表A9 11-12-18 03-11.rar (293.49 KB, 下载次数: 216)

2011-12-18 03:12 上传

点击文件名下载附件

tjcjdx

可以参考一下这个
http://blog.sina.com.cn/s/blog_436dc2b8010118zw.html
楼主应该是江苏邳州人吧

星语心愿

我吗？贵州省毕节的，小学教师。
谢谢楼上的朋友，我马上试试。

星语心愿

你好。可以再做个合并的表格代码吗？比如各班处理好以后，我再反过来导入数据。
还有，为什么导出的表格第一次打开的时候都出现如下的一个出错对话框。希望导出的数据格式能自动加上边框，并保留原来的格式。

孤独行星双星记

楼主好，我根据你的需要，弄了个VBA的东东，功能是可以按G列（学校）对工作簿进行拆分后核对，都核对完成后，再放到另一文件夹中进行汇总。请试下。为了防止VBA被不经意乱改，特地进行了密码保护和工程锁定。如果有需要的话，请联系：125301867@qq.com

孤独行星双星记

请先试用下，好用的话，我再把代码发给你。

孤独行星双星记

本人是菜鸟，也是参考他人VBA代码做的，互相学习。

冲天妖狐

AVEL 发表于 2011-12-18 03:09

代码要是能加上解释，就更好了，方便学习……