利用VBA将成绩录入表中各年级前30名学生数据复制生成新的工作表

tdpca

taller 发表于 2020-10-18 10:45
示例文件

要求新的工作表插入空白表生成的，删除3个成生的表模后，测试没通过

tdpca

bajifeng 发表于 2020-10-18 04:35
>>>>>>>>>>>>>>>>

多谢老师，调试成功。

taller

tdpca 发表于 2020-10-18 12:07
要求新的工作表插入空白表生成的，删除3个成生的表模后，测试没通过

不明白你的要求，1楼没有说明

donghui2363

tdpca 发表于 2020-10-18 12:02
老师，测试卡在.
ConnectionString = "Extended Properties='Excel 12.0;HDR=YES';Data Source=" & This ...

用6楼的连接方式

tdpca

bajifeng 发表于 2020-10-18 04:35
>>>>>>>>>>>>>>>>

老师，请问删减第一行“成绩录入“一行，代码该如何修改

bajifeng

tdpca 发表于 2020-10-18 15:27
老师，请问删减第一行“成绩录入“一行，代码该如何修改

sh.[a2].Resize(1, UBound(br, 2)).Copy [a1]
改为
sh.[a1].Resize(1, UBound(br, 2)).Copy [a1]

tdpca

bajifeng 发表于 2020-10-18 16:11
sh.[a2].Resize(1, UBound(br, 2)).Copy [a1]
改为
sh.[a3].Resize(1, UBound(br, 2)).Copy [a1]

多谢老师！

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.   mc = Application.InputBox(prompt:="请输入需要筛选的名次：", Title:="操作提示", Default:=30, Type:=1)
   
9.   With Worksheets("成绩录入")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
12.     arr = .Range("a2").Resize(r - 1, c)
    
13.   End With
    
14.   For i = 2 To UBound(arr)
    
15.     If arr(i, 16) <= mc Then
    
16.       If Not d.exists(arr(i, 1)) Then
    
17.         m = 1
    
18.         ReDim brr(1 To UBound(arr, 2), 1 To m)
    
19.       Else
    
20.         brr = d(arr(i, 1))
    
21.         m = UBound(brr, 2) + 1
    
22.         ReDim Preserve brr(1 To UBound(arr, 2), 1 To m)
    
23.       End If
    
24.       For j = 1 To UBound(arr, 2)
    
25.         brr(j, m) = arr(i, j)
    
26.       Next
    
27.       d(arr(i, 1)) = brr
    
28.     End If
    
29.   Next
    
30.   For Each aa In d.keys
    
31.     brr = d(aa)
    
32.     ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
33.     For i = 1 To UBound(brr)
    
34.       For j = 1 To UBound(brr, 2)
    
35.         crr(j, i) = brr(i, j)
    
36.       Next
    
37.     Next
    
38.     shtname = Application.Text(aa, "[DBNum1]") & "年级前" & mc & "名单"
    
39.     On Error Resume Next
    
40.     Set ws = Worksheets(shtname)
    
41.     If Err Then
    
42.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
43.       ws.Name = shtname
    
44.     End If
    
45.     On Error GoTo 0
    
46.     With ws
    
47.       .Cells.Clear
    
48.       .Range("a1").Resize(1, UBound(arr, 2)) = Application.Index(arr, 1, 0)
    
49.       .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
    
50.       With .Range("a1").Resize(1 + UBound(crr), UBound(crr, 2))
    
51.         .Borders.LineStyle = xlContinuous
    
52.         With .Font
    
53.           .Name = "微软雅黑"
    
54.           .Size = 11
    
55.         End With
    
56.       End With
    
57.       .Columns(1).Resize(, UBound(crr, 2)).AutoFit
    
58.       .Range("a1").Resize(1 + UBound(crr), UBound(crr, 2)).Sort key1:=.Cells(1, UBound(crr, 2)), order1:=xlAscending, Header:=xlYes
    
59.       With .UsedRange
    
60.         .HorizontalAlignment = xlCenter
    
61.         .VerticalAlignment = xlCenter
    
62.       End With
    
63.     End With
    
64.   Next
    
65.   Application.ScreenUpdating = True
    
66.   MsgBox "成绩统计完毕！"
    
67. End Sub
    

复制代码

chxw68

详见附件。

tdpca

chxw68 发表于 2020-10-19 09:04
详见附件。

多谢大师!!!