ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 452|回复: 18

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-10-18 01:09 | 显示全部楼层 |阅读模式
求:利用VBA将成绩录入表中各年级前30名学生数据复制生成新的工作表

成绩总表.rar

398.47 KB, 下载次数: 15

TA的精华主题

TA的得分主题

发表于 2020-10-18 04:34 | 显示全部楼层
  1. Sub ba()    'by bajifeng | QQ:249346223
  2. nr = Array("七", "八", "九")
  3. gr = Array(7, 8, 9)
  4. ns = "年级前30名单"
  5. Set sh = Sheets("成绩录入")
  6. ar = sh.Range("a1:p" & sh.[a65336].End(3).Row)
  7. For ii = 0 To UBound(nr)
  8.     chk = False
  9.     For i = Sheets.Count To 1 Step -1
  10.         If InStr(Sheets(i).Name, nr(ii) & ns) Then
  11.             br = gradeAr(ar, gr(ii))
  12.             Sheets(i).Select
  13.             [a2].Resize(UBound(br), UBound(br, 2)) = br
  14.             Call grade30
  15.             chk = True
  16.             Exit For
  17.         End If
  18.         If i = 1 And chk = False Then
  19.             Sheets.Add after:=Sheets(Sheets.Count)
  20.             Sheets(Sheets.Count).Name = nr(ii) & ns
  21.             br = gradeAr(ar, gr(ii))
  22.             sh.[a2].Resize(1, UBound(br, 2)).Copy [a1]
  23.             [a2].Resize(UBound(br), UBound(br, 2)) = br
  24.             Call grade30
  25.         End If
  26.     Next
  27. Next
  28. sh.Select
  29. MsgBox "Done!"
  30. End Sub
  31. Function gradeAr(ar, grade)
  32. Dim br()
  33. For i = 1 To UBound(ar)
  34.     If CStr(ar(i, 1)) = CStr(grade) Then
  35.         n = n + 1
  36.         ReDim Preserve br(1 To UBound(ar, 2), 1 To n)
  37.         For j = 1 To UBound(ar, 2)
  38.             br(j, n) = ar(i, j)
  39.         Next
  40.     End If
  41. Next
  42. gradeAr = Application.Transpose(br)
  43. End Function
  44. Sub grade30()
  45. If [a65536].End(3).Row = 1 Then Exit Sub
  46. Dim rg As Range
  47. Set rg = Range([a1], ActiveSheet.UsedRange)
  48. rg.Sort [p1], 1, Header:=xlYes
  49. rg.Borders.LineStyle = 1
  50. rg.HorizontalAlignment = xlCenter
  51. [a32:p999].Clear
  52. End Sub
复制代码

评分

参与人数 1财富 +10 收起 理由
lsc900707 + 10 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-10-18 04:35 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-10-18 07:54 | 显示全部楼层
请测试
  1. Sub 班级()
  2. Dim sht As Worksheet
  3. Dim cnn As New ADODB.Connection
  4.     With cnn
  5.         .Provider = "Microsoft.Ace.Oledb.12.0"
  6.         .ConnectionString = "Extended Properties='Excel 12.0;HDR=YES';Data Source=" & ThisWorkbook.FullName
  7.         .Open
  8.     End With
  9.     arr = Sheet1.Range("a2:p2")
  10.     Sql = "select distinct 级名 from [成绩录入$a2:p] where 级名 is not null"
  11.     brr = cnn.Execute(Sql).GetRows
  12.     For i = 0 To UBound(brr, 2)
  13.         Set sht = Worksheets.Add
  14.         sht.Name = brr(0, i) & "级前30名"
  15.         sht.Range("a1:p1") = arr
  16.         Sql = "select top 30 * from [成绩录入$a2:p] where 级名='" & brr(0, i) & "' order by 级排名"
  17.         sht.Range("a2").CopyFromRecordset cnn.Execute(Sql)
  18.     Next i
  19.     cnn.Close
  20.     Set cnn = Nothing
  21. End Sub
复制代码

评分

参与人数 1鲜花 +3 收起 理由
abc123281 + 3 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-10-18 07:58 | 显示全部楼层
把Dim cnn As New ADODB.Connection换成
Set cnn = CreateObject("adodb.connection")

TA的精华主题

TA的得分主题

发表于 2020-10-18 08:42 | 显示全部楼层
  1. Sub AA()
  2.     Dim Conn As Object, Rst As Object
  3.     Dim strConn As String, strSQL As String
  4.     Dim i As Integer, PathStr As String
  5.     Set Conn = CreateObject("ADODB.Connection")
  6.     Set Rst = CreateObject("ADODB.Recordset")
  7.     PathStr = ThisWorkbook.FullName   '设置工作簿的完整路径和名称
  8.     Select Case Application.Version * 1    '设置连接字符串,根据版本创建连接
  9.     Case Is <= 11
  10.         strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
  11.     Case Is >= 12
  12.         strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
  13.     End Select
  14.     '设置SQL查询语句
  15.     strSQL = "SELECT * FROM [成绩录入$A2:P]  WHERE  级名=7 "
  16.     strSQL = "select * from (" & strSQL & ")  order by 级排名 " '',ASE
  17.     Conn.Open strConn    '打开数据库链接
  18.     Set Rst = Conn.Execute(strSQL)    '执行查询,并将结果输出到记录集对象
  19.     With ActiveSheet
  20.         .Cells.Clear
  21.         For i = 0 To Rst.Fields.Count - 1    '填写标题
  22.             .Cells(1, i + 1) = Rst.Fields(i).Name
  23.         Next i
  24.         .Range("A2").CopyFromRecordset Rst, 30
  25.         .Cells.EntireColumn.AutoFit  '自动调整列宽
  26.         .Cells.EntireColumn.AutoFit  '自动调整列宽
  27.     End With
  28.     Rst.Close    '关闭数据库连接
  29.     Conn.Close
  30.     Set Conn = Nothing
  31.     Set Rst = Nothing
  32. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2020-10-18 09:45 | 显示全部楼层
donghui老师:
Sql = "select top 30 * from [成绩录入$a2:p] where  级名 =" & brr(0, i) & " order by 级排名"
excel2013应该是这样才能运行

评分

参与人数 1鲜花 +3 收起 理由
abc123281 + 3 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-10-18 10:44 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-10-18 10:45 | 显示全部楼层
示例文件

成绩总表.7z

129.78 KB, 下载次数: 7

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-10-18 12:02 | 显示全部楼层

老师,测试卡在.
ConnectionString = "Extended Properties='Excel 12.0;HDR=YES';Data Source=" & ThisWorkbook.FullName
       .Open
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-10-30 21:19 , Processed in 0.089338 second(s), 21 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表