根据总表和班主任表生成班级表

闻启学

hjd528 发表于 2024-2-1 21:54
谢谢！但每个班级表还要进行页面设置。

代码 已经修改

limonet

关键字：distinct

limonet

Sub limonet()
    Dim Cn As Object, Rst As Object, StrSQL$, Arr As Variant, Brr As Variant
    Brr = Sheet1.Range("A3:A62")
    Set Cn = CreateObject("Adodb.Connection")
    Set Rst = CreateObject("adodb.recordset")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Arr = Cn.Execute("Select Distinct 班级 From [总表$B2:J]").Getrows
    For i = 0 To UBound(Arr, 2)
        Sheet15.Copy after:=Worksheets(Sheets.Count)
        ActiveSheet.Name = Arr(0, i)
        Range("B2") = Arr(0, i)
        Range("I2").CopyFromRecordset Cn.Execute("Select 班主任 From [班主任$] Where 班级=" & Arr(0, i))
        StrSQL = "Select 姓名,性别,身份证号,学籍号,现居住地址,监护人,联系电话,备注 From [总表$B2:J] Where 班级=" & Arr(0, i)
        Rst.Open StrSQL, Cn, 1, 3
        Range("A4").Resize(Rst.RecordCount, 1) = Brr: Range("B4").CopyFromRecordset Rst
        Range(Cells(Rst.RecordCount + 4, "A"), Cells(100, "I")).Clear
        Rst.Close
    Next i
End Sub

闻启学

lushang2018 发表于 2024-2-1 21:50

亲  代码与我写的 与差不多，思路和方法 ，班主任 这里可以用字典来处理  有机会交流一下

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object, dc As Object
Dim arr()
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 2 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
Set sht = Sheets("总表")
With Sheets("班主任")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "班主任工作表为空！": End
    ar = .Range("a1:b" & r)
End With
For i = 2 To UBound(ar)
    d(ar(i, 1)) = ar(i, 2)
Next i
With sht
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    If rs < 3 Then MsgBox "总表为空！": End
    br = .Range(.Cells(2, 1), .Cells(rs, y))
End With
For i = 2 To UBound(br)
    If Trim(br(i, 3)) <> "" Then
        dc(br(i, 3)) = ""
    End If
Next i
For Each k In dc.keys
    n = 0
    ReDim arr(1 To UBound(br), 1 To UBound(br, 2) - 1)
    For i = 2 To UBound(br)
        If br(i, 3) = k Then
            n = n + 1
            arr(n, 1) = n
            arr(n, 2) = br(i, 2)
            For j = 4 To UBound(br, 2)
                arr(n, j - 1) = br(i, j)
            Next j
        End If
    Next i
    sht.Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = k
        .Columns(3).Delete
        .Rows("2:2").Insert Shift:=xlDown
        .Range(.Cells(1, 1), .Cells(1, y)).Borders.LineStyle = 0
        With .Range(.Cells(2, 1), .Cells(2, y)).Font
            .Name = "宋体"
            .Size = 12
            .Bold = True
        End With
        With .Range(.Cells(4, 1), .Cells(r, y))
            .ClearContents
            .Borders.LineStyle = 0
        End With
        .[a2] = "班级："
        .[h2] = "班主任："
        .[b2] = k
        .[i2] = d(k)
        .[a4].Resize(n, UBound(arr, 2)) = arr
        .[a4].Resize(n, UBound(arr, 2)).Borders.LineStyle = 1
    End With
Next k
Application.ScreenUpdating = True
MsgBox "拆分完毕！"
End Sub

3190496160

保留总表所有格式包括页面设置拆分
根据总表和班主任表生成班级表.rar (78.4 KB, 下载次数: 16)

2024-2-2 09:30 上传

点击文件名下载附件

hjd528

3190496160 发表于 2024-2-2 09:30
保留总表所有格式包括页面设置拆分

谢谢朱老师！不是班级的多余人员未删除，能否抽空完善。

hjd528

limonet 发表于 2024-2-1 22:59
Sub limonet()
    Dim Cn As Object, Rst As Object, StrSQL$, Arr As Variant, Brr As Variant
    Brr ...

谢谢老师的的帮助。如果班级表已生成的话，运行代码时会报错。我找了一段代码，先删除已生成的班级表，完美解决。

3190496160

一个字母的错误，已修正
根据总表和班主任表生成班级表.rar (57.49 KB, 下载次数: 16)

2024-2-2 10:33 上传

点击文件名下载附件

hjd528

3190496160 发表于 2024-2-2 10:33
一个字母的错误，已修正

谢谢朱老师，还有一个问题，就是总表中的最后行在每个班级中都出现，还得麻烦您看一看。