按标准提取信息

zxc00

zhaogang1960 发表于 2014-2-2 21:27
请看附件

7楼的附件，问题改为：达到标准分数的提取前三名，排除没有数据的年级

zhaogang1960

zxc00 发表于 2014-2-4 22:40
7楼的附件，问题改为：达到标准分数的提取前三名，排除没有数据的年级

1. Private Sub CommandButton2_Click()
   
2.     Dim cnn As Object, rs As Object, SQL$, arr, brr&(), i&, j&, lr&, t$, objWMI As Object
   
3.     Const HKEY_LOCAL_MACHINE = &H80000002
   
4.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
5.     objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 100
   
6.     Set cnn = CreateObject("ADODB.Connection")
   
7.     cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0;imex=1';Data Source =" & ThisWorkbook.FullName
   
8.     SQL = "select distinct left(班别,1) from [总表$] where iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1)>0"
   
9.     arr = cnn.Execute(SQL).GetRows
   
10.     Range("a1").CurrentRegion.Offset(1).ClearContents
    
11.     For i = 0 To UBound(arr, 2)
    
12.         SQL = "select top 3 班别,姓名,iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1) as 总分,null,left(班别,1) as 所属年级 from [总表$] where left(班别,1)='" _
    
13.             & arr(0, i) & "' order by iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1) desc"
    
14.         Set rs = CreateObject("ADODB.Recordset")
    
15.         rs.Open SQL, cnn, 1, 3
    
16.         ReDim brr(1 To rs.RecordCount, 1 To 1)
    
17.         brr(1, 1) = 1
    
18.         t = rs.Fields(2)
    
19.         rs.MoveNext
    
20.         For j = 2 To rs.RecordCount
    
21.             If rs.Fields(2) = t Then
    
22.                 brr(j, 1) = brr(j - 1, 1)
    
23.             Else
    
24.                 brr(j, 1) = j
    
25.             End If
    
26.             t = rs.Fields(2)
    
27.             rs.MoveNext
    
28.         Next
    
29.         rs.MoveFirst
    
30.         lr = Range("a65536").End(xlUp).Row + 1
    
31.         Range("a" & lr).CopyFromRecordset rs
    
32.         Range("d" & lr).Resize(j - 1) = brr
    
33.     Next
    
34.     rs.Close
    
35.     cnn.Close
    
36.     Set rs = Nothing
    
37.     Set cnn = Nothing
    
38. End Sub
    

复制代码

zhaogang1960

请测试附件
按标准提取信息.rar (23.38 KB, 下载次数: 10)

2014-2-4 22:54 上传

点击文件名下载附件

zxc00

zhaogang1960 发表于 2014-2-4 22:55
请测试附件

谢谢，不过A列的顺序都乱了，能按升序排吗

zhaogang1960

zxc00 发表于 2014-2-4 23:41
谢谢，不过A列的顺序都乱了，能按升序排吗

1. Private Sub CommandButton2_Click()
   
2.     Dim cnn As Object, rs As Object, SQL$, arr, brr&(), i&, j&, lr&, t$, objWMI As Object
   
3.     Const HKEY_LOCAL_MACHINE = &H80000002
   
4.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
5.     objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 100
   
6.     Set cnn = CreateObject("ADODB.Connection")
   
7.     cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0;imex=1';Data Source =" & ThisWorkbook.FullName
   
8.     SQL = "select distinct left(班别,1) as 班 from [总表$] where iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1)>0"
   
9.     SQL = "select 班 from (" & SQL & ") order by instr('一,二,三,四,五,六',班)"
   
10.     arr = cnn.Execute(SQL).GetRows
    
11.     Range("a1").CurrentRegion.Offset(1).ClearContents
    
12.     For i = 0 To UBound(arr, 2)
    
13.         SQL = "select top 3 班别,姓名,iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1) as 总分,null,left(班别,1) as 所属年级 from [总表$] where left(班别,1)='" _
    
14.             & arr(0, i) & "' order by iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1) desc"
    
15.         Set rs = CreateObject("ADODB.Recordset")
    
16.         rs.Open SQL, cnn, 1, 3
    
17.         ReDim brr(1 To rs.RecordCount, 1 To 1)
    
18.         brr(1, 1) = 1
    
19.         t = rs.Fields(2)
    
20.         rs.MoveNext
    
21.         For j = 2 To rs.RecordCount
    
22.             If rs.Fields(2) = t Then
    
23.                 brr(j, 1) = brr(j - 1, 1)
    
24.             Else
    
25.                 brr(j, 1) = j
    
26.             End If
    
27.             t = rs.Fields(2)
    
28.             rs.MoveNext
    
29.         Next
    
30.         rs.MoveFirst
    
31.         lr = Range("a65536").End(xlUp).Row + 1
    
32.         Range("a" & lr).CopyFromRecordset rs
    
33.         Range("d" & lr).Resize(j - 1) = brr
    
34.     Next
    
35.     rs.Close
    
36.     cnn.Close
    
37.     Set rs = Nothing
    
38.     Set cnn = Nothing
    
39. End Sub
    

复制代码

zhaogang1960

请看附件
按标准提取信息.rar (23.55 KB, 下载次数: 12)

2014-2-4 23:50 上传

点击文件名下载附件

zxc00

zhaogang1960 发表于 2014-2-4 23:49

谢谢，试试先

zxc00

zhaogang1960 发表于 2014-2-3 21:32
请测试附件

14楼的附件运行结果还有一点小问题。

题目要求是：按上面的标准分数，达到标准分数的提取前三名，没达到的则提取该年级的前三名。。

如有一个年级只有一个学生的总分达到，那就提取一个，就不再提取前三名了。
如有一个年级没有一个学生的总分达到，那就提取前三名。

zhaogang1960

zxc00 发表于 2014-2-5 21:26
14楼的附件运行结果还有一点小问题。

题目要求是：按上面的标准分数，达到标准分数的提取前三名，没达 ...

1. Private Sub CommandButton2_Click()
   
2.     Dim cnn As Object, rs As Object, SQL$, arr, brr&(), i&, j&, lr&, t$, objWMI As Object
   
3.     Const HKEY_LOCAL_MACHINE = &H80000002
   
4.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
5.     objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 100
   
6.     Set cnn = CreateObject("ADODB.Connection")
   
7.     cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0;imex=1';Data Source =" & ThisWorkbook.FullName
   
8.     arr = Range("G11:H" & Range("G65536").End(xlUp).Row)
   
9.     Range("a1").CurrentRegion.Offset(1).ClearContents
   
10.     For i = 1 To UBound(arr)
    
11.         SQL = "select top 3 班别,姓名,iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1) as 总分,null,left(班别,1) as 所属年级 from [总表$] where left(班别,1)='" _
    
12.             & arr(i, 1) & "' and iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1)" & arr(i, 2) & " order by iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1) desc"
    
13.         Set rs = CreateObject("ADODB.Recordset")
    
14.         rs.Open SQL, cnn, 1, 3
    
15.         If rs.RecordCount = 0 Then
    
16.             SQL = "select top 3 班别,姓名,iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1) as 总分,null,left(班别,1) as 所属年级 from [总表$] where left(班别,1)='" _
    
17.                 & arr(i, 1) & "' order by iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1) desc"
    
18.             Set rs = CreateObject("ADODB.Recordset")
    
19.             rs.Open SQL, cnn, 1, 3
    
20.         End If
    
21.         ReDim brr(1 To rs.RecordCount, 1 To 1)
    
22.         brr(1, 1) = 1
    
23.         t = rs.Fields(2)
    
24.         rs.MoveNext
    
25.         For j = 2 To rs.RecordCount
    
26.             If rs.Fields(2) = t Then
    
27.                 brr(j, 1) = brr(j - 1, 1)
    
28.             Else
    
29.                 brr(j, 1) = j
    
30.             End If
    
31.             t = rs.Fields(2)
    
32.             rs.MoveNext
    
33.         Next
    
34.         rs.MoveFirst
    
35.         lr = Range("a65536").End(xlUp).Row + 1
    
36.         Range("a" & lr).CopyFromRecordset rs
    
37.         Range("d" & lr).Resize(j - 1) = brr
    
38.     Next
    
39.     rs.Close
    
40.     cnn.Close
    
41.     Set rs = Nothing
    
42.     Set cnn = Nothing
    
43. End Sub
    

复制代码

zhaogang1960

请测试附件
按标准提取信息2.5.rar (23.12 KB, 下载次数: 14)

2014-2-5 22:14 上传

点击文件名下载附件