学生按班级导出，并能查询缴费数据

cdllh

我有一个学生的收费表，麻烦前辈帮个忙。



需要以“学生总名单”里的身份证号码，姓名，班级，复制到“明细”里对应的列。
要点：1、按班级要分成对应的“班级名称”的.xlsx文件。包含”明细“和”银行收费情况“二个工作簿
         2、”明细“里身份证号码，姓名，班级，三项，可以是数值，但是其他查询数据列要是公式，因为要查询”银行收费情况“的数据
         3、”银行收费情况“是获取的其他汇总表的数据，这个数据随时在更新，也不能是数值。
         4、每个生成的文件，二个表再顺便加一个保护工作簿最好，密码就为“1”
麻烦前辈帮个忙。感谢！
收费表测试.zip (31.59 KB, 下载次数: 30)

2023-2-7 23:05 上传

点击文件名下载附件

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set sht = Sheets("银行收费情况")
Set sh = Sheets("明细")
With Sheets("学生总名单")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "学生总名单为空！": End
    ar = .Range("a1:c" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 3)) <> "" Then
        d(Trim(ar(i, 3))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To 4)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 3)) = k Then
            n = n + 1
            br(n, 1) = n
            br(n, 2) = ar(i, 2)
            br(n, 3) = ar(i, 3)
            br(n, 4) = ar(i, 1)
        End If
    Next i
    sh.Copy
    Set wb = ActiveWorkbook
    With wb.Worksheets(1)
        .[a2].Resize(n, 3) = br
        .[e2].Resize(n, 1) = Application.Index(br, 0, 4)
    End With
    sht.Copy after:=wb.Worksheets(wb.Worksheets.Count)
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close
Next k
Application.ScreenUpdating = True
MsgBox "完毕！"
End Sub

3190496160

3190496160

收费表测试.rar (43.44 KB, 下载次数: 27)

2023-2-8 11:43 上传

点击文件名下载附件

3190496160

不是很明白你的需求，代码仅供参考，有问题再说吧

cdllh

3190496160 发表于 2023-2-8 11:44
不是很明白你的需求，代码仅供参考，有问题再说吧

老大，就是这样的。现在的问题是明细表中的身份证不是文本，显示乱码。非常感谢。

3190496160

cdllh 发表于 2023-2-8 11:54
老大，就是这样的。现在的问题是明细表中的身份证不是文本，显示乱码。非常感谢。

你也是教师，这点基本的常识，应该是知道的吧：事先设置明细表身份证列为文本格式不就行了吗

cdllh

呵呵。早上很兴奋，忘记了。

ykcbf1100

参与一下。

cdllh

感谢大神些，终于又有时间摸鱼了。呵呵