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

annnie安妮

lushang2018 发表于 2023-2-6 17:40
代码仅供参考

谢谢大佬，程序运行很流畅

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     With Worksheets("分数线")
   
10.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
11.         arr = .Range("a1").Resize(2, c)
    
12.         For j = 1 To UBound(arr, 2)
    
13.             km = Left(arr(1, j), 2)
    
14.             d1(km) = arr(2, j)
    
15.         Next
    
16.     End With
    
17.     With Worksheets("成绩表")
    
18.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
20.         arr = .Range("a1").Resize(r, c)
    
21.         For j = 3 To UBound(arr, 2) Step 2
    
22.             If d1.exists(arr(1, j)) Then
    
23.                 fs = d1(arr(1, j))
    
24.                 For i = 2 To UBound(arr)
    
25.                     If arr(i, j) >= fs Then
    
26.                         If Not d.exists(arr(1, j)) Then
    
27.                             Set d(arr(1, j)) = .Range("a1").Resize(1, c)
    
28.                         End If
    
29.                         Set d(arr(1, j)) = Union(d(arr(1, j)), .Cells(i, 1).Resize(1, c))
    
30.                     End If
    
31.                 Next
    
32.             End If
    
33.         Next
    
34.     End With
    
35.     For Each aa In d.keys
    
36.         On Error Resume Next
    
37.         Set ws = Worksheets(aa)
    
38.         If Err Then
    
39.             Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
40.             ws.Name = aa
    
41.         End If
    
42.         On Error GoTo 0
    
43.         With ws
    
44.             .Cells.Clear
    
45.             d(aa).Copy .Range("a1")
    
46.         End With
    
47.     Next
    
48.             
    
49. '    With .UsedRange
    
50. '        .HorizontalAlignment = xlCenter
    
51. '        .VerticalAlignment = xlCenter
    
52. '    End With
    
53. '    With Worksheets("sheet1")
    
54. '        r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
55. '        c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    
56. '    End With
    
57. End Sub
    

复制代码

chxw68

参与一下。