通过各科分数线将学生成绩分到不同工作簿

annnie安妮

用VBA程序，将各科分数线（sheet1）将全校总成绩中（sheet2）上线学生（成绩大于等于分数线）的数据分解到对应的工作簿中：

比如：1.语文分数线为91分，那么语文成绩≥91的学生数据复制到对应的《语文》工作簿中。
2.分数线变化的时候，启动宏命令，相对应的数据也会及时更新

恳请各位大佬帮助

蓝桥玄霜

名单的例子：

mmwwdd

annnie安妮

蓝桥玄霜 发表于 2023-2-6 14:34
名单的例子：

谢谢大佬

annnie安妮

mmwwdd 发表于 2023-2-6 15:58

谢谢大佬

lushang2018

代码仅供参考

1. Sub 测试()
   
2.     Dim i%, j%, k%, m%, n%, arr, brr, sht As Worksheet
   
3.     arr = Sheet1.Range("A1").CurrentRegion
   
4.     brr = Sheet2.Range("A1").CurrentRegion
   
5.     Dim 科目, 分数线
   
6.     For j = 2 To UBound(arr, 2)
   
7.         科目 = Left(arr(1, j), 2)
   
8.         分数线 = arr(2, j)
   
9.         k = 0
   
10.         For m = 5 To 22 Step 2
    
11.             If brr(1, m) = 科目 Then
    
12.                 ReDim crr(1 To 1000, 1 To 4)
    
13.                 crr(1, 1) = "班级": crr(1, 2) = "姓名": crr(1, 3) = 科目: crr(1, 4) = "校次"
    
14.                 For i = 2 To UBound(brr)
    
15.                     If brr(i, m) >= 分数线 Then
    
16.                         k = k + 1
    
17.                         crr(k + 1, 1) = brr(i, 1)
    
18.                         crr(k + 1, 2) = brr(i, 2)
    
19.                         crr(k + 1, 3) = brr(i, m)
    
20.                         crr(k + 1, 4) = brr(i, m + 1)
    
21.                     End If
    
22.                 Next
    
23.             End If
    
24.         Next
    
25.         For Each sht In ThisWorkbook.Worksheets
    
26.             If sht.Name = 科目 Then
    
27.                 sht.Range("A1").Resize(k + 1, 4) = crr
    
28.             End If
    
29.         Next
    
30.     Next
    
31. End Sub

复制代码

lushang2018

limonet

代码在审核。

limonet

Sub SplitData()
    Dim Cn As Object, SQL$, Arr As Variant, i%
    Set Cn = CreateObject("adodb.connection")
        Cn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName
    Arr = Worksheets("分数线").Range("A1").CurrentRegion
    For i = 1 To UBound(Arr, 2)
        FieldName = Left(Arr(1, i), 2)
        SQL = "select 班级,姓名," & FieldName & "," & Worksheets("成绩表").Cells(1, WorksheetFunction.Match(FieldName, Worksheets("成绩表").Range("A1:V1"), 0) + 1) & " from [成绩表$] where " & FieldName & ">=" & Arr(2, i)
        Worksheets(FieldName).Range("A1").Resize(1, 4) = Array("班级", "姓名", FieldName, Worksheets("成绩表").Cells(1, WorksheetFunction.Match(FieldName, Worksheets("成绩表").Range("A1:V1"), 0) + 1))
        Worksheets(FieldName).Range("A2").CopyFromRecordset Cn.Execute(SQL)
    Next i
End Sub

annnie安妮

lushang2018 发表于 2023-2-6 17:41

谢谢大佬的帮助