根据总表拆分成工作表并分为两栏

foreversun

折分成工作表并分为两栏.rar (20.27 KB, 下载次数: 66)

2017-2-8 02:12 上传

点击文件名下载附件

将总表拆分成工作表网上有现成的。但拆分后还要分为两栏，并在每张表前面插入两行。请教如何实现。

新问题
班级        班主任        电话
1班        ww1        1
2班        ww2        2
3班        ww3        3
4班        ww4        4
5班        ww5        5
6班        ww6        6
7班        ww7        7
8班        ww8        8
9班        ww9        9
10班        ww10        10
15班        ww11        15
16班        ww12        16
将班级 班主任 电话信息 放在N1:p13
能否将此信息写入对应工作表.
比如: 1班  
a2="1班班主任"  b2="w1" c2=1
这个要用到字典吧.
对字典不很明白.
应该如何处理呢

魂断蓝桥

Sub a()
Dim sh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each sh In Sheets
    If sh.Name <> "总表" Then
        sh.Delete
    End If
Next
Dim cnn, cnn1, rs, rs1, Sqa$, bt, j%, m%, sqb$, arr
bt = [{"姓名","班级","总分","总分排名","总分班级排名"}]
Set cnn = CreateObject("adodb.connection")
Set cnn1 = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.Recordset")
Set rs1 = CreateObject("adodb.Recordset")
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
cnn1.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
Sqa = "select distinct 班级,COUNT(*) from [总表$b1:b] where 班级 is not null GROUP BY 班级"
rs.Open Sqa, cnn, 1, 1
Do While Not rs.EOF
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = rs.Fields(0)
    [a1:j1].Merge
    [a1] = rs.Fields(0) & "成绩表"
    [a1].HorizontalAlignment = xlCenter
    [a2] = rs.Fields(0) & "班主任"
    sqb = "select * from [总表$a1:e] where 班级='" & rs.Fields(0) & "'"
    rs1.Open sqb, cnn1, 1, 1
        For j = 0 To Round(rs.Fields(1) / 30 + 0.49, 0) - 1
            [a3].Offset(0, j * 5).Resize(1, 5) = bt
            arr = Application.Transpose(rs1.getRows(30, 0))
            [a4].Offset(0, j * 5).Resize(UBound(arr), 5) = arr
            [a3].Offset(0, j * 5).Resize(UBound(arr) + 1, 5).Borders.LineStyle = 1
        Next
        rs1.Close
    rs.MoveNext
Loop
Set rs = Nothing
Set cnn = Nothing
Set rs1 = Nothing
Set cnn1 = Nothing
Application.ScreenUpdating = True
End Sub

foreversun

魂断蓝桥 发表于 2017-2-8 10:04
Sub a()
Dim sh As Worksheet
Application.DisplayAlerts = False

谢谢你,将sql 发挥得淋漓尽致  但有一点不合意:分的两栏不是平均分的.是左三十.能不能平均分开呢.

foreversun

朱荣兴 发表于 2017-2-8 11:25

朱老师真是太好了,达到了效果
如果能随意增加减少列字段就好了.找到了.将这里改为
sh.[f3].Resize(1, UBound(arr, 2)) = arr

sh.cells(3,?).Resize(1, UBound(arr, 2)) = arr
?为例数即可.
再次谢谢

魂断蓝桥

foreversun 发表于 2017-2-8 11:09
谢谢你,将sql 发挥得淋漓尽致  但有一点不合意:分的两栏不是平均分的.是左三十.能不能平均分开呢.

Sub a()
Dim sh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each sh In Sheets
    If sh.Name <> "总表" Then
        sh.Delete
    End If
Next
Dim cnn, cnn1, rs, rs1, Sqa$, bt, j%, m%, sqb$, arr
bt = [{"姓名","班级","总分","总分排名","总分班级排名"}]
Set cnn = CreateObject("adodb.connection")
Set cnn1 = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.Recordset")
Set rs1 = CreateObject("adodb.Recordset")
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
cnn1.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
Sqa = "select distinct 班级,COUNT(*) from [总表$b1:b] where 班级 is not null GROUP BY 班级"
rs.Open Sqa, cnn, 1, 1
Do While Not rs.EOF
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = rs.Fields(0)
    [a1:j1].Merge
    [a1] = rs.Fields(0) & "成绩表"
    [a1].HorizontalAlignment = xlCenter
    [a2] = rs.Fields(0) & "班主任"
    sqb = "select * from [总表$a1:e] where 班级='" & rs.Fields(0) & "'"
    rs1.Open sqb, cnn1, 1, 1
    m = Round(rs1.RecordCount / 2 + 0.49, 0)
        For j = 0 To 1
            [a3].Offset(0, j * 5).Resize(1, 5) = bt
            arr = Application.Transpose(rs1.getRows(m, 0))
            [a4].Offset(0, j * 5).Resize(UBound(arr), 5) = arr
            [a3].Offset(0, j * 5).Resize(UBound(arr) + 1, 5).Borders.LineStyle = 1
        Next
        rs1.Close
    rs.MoveNext
Loop
Set rs = Nothing
Set cnn = Nothing
Set rs1 = Nothing
Set cnn1 = Nothing
Application.ScreenUpdating = True
End Sub

foreversun

感谢 朱荣兴  魂断蓝桥  都实现了我想要的功能.