按标准提取信息

zxc00

zhaogang1960 发表于 2014-2-5 22:15
请测试附件

如果题目要求是：按上面的标准分数，达到标准分数的提取前三名，排除没有数据的年级

zhaogang1960

zxc00 发表于 2014-2-5 22:33
如果题目要求是：按上面的标准分数，达到标准分数的提取前三名，排除没有数据的年级

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 班别 from [总表$] where left(班别,1)='" & arr(i, 1) & "' and iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1)>0"
    
12.         Set rs = cnn.Execute(SQL)
    
13.         If Not rs.BOF And Not rs.EOF Then
    
14.             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)='" _
    
15.                 & 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"
    
16.             Set rs = CreateObject("ADODB.Recordset")
    
17.             rs.Open SQL, cnn, 1, 3
    
18.             If rs.RecordCount = 0 Then
    
19.                 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)='" _
    
20.                     & arr(i, 1) & "' order by iif(isnull(语文),0,语文*1)+iif(isnull(数学),0,数学*1)+iif(isnull(英语),0,英语*1) desc"
    
21.                 Set rs = CreateObject("ADODB.Recordset")
    
22.                 rs.Open SQL, cnn, 1, 3
    
23.             End If
    
24.             ReDim brr(1 To rs.RecordCount, 1 To 1)
    
25.             brr(1, 1) = 1
    
26.             t = rs.Fields(2)
    
27.             rs.MoveNext
    
28.             For j = 2 To rs.RecordCount
    
29.                 If rs.Fields(2) = t Then
    
30.                     brr(j, 1) = brr(j - 1, 1)
    
31.                 Else
    
32.                     brr(j, 1) = j
    
33.                 End If
    
34.                 t = rs.Fields(2)
    
35.                 rs.MoveNext
    
36.             Next
    
37.             rs.MoveFirst
    
38.             lr = Range("a65536").End(xlUp).Row + 1
    
39.             Range("a" & lr).CopyFromRecordset rs
    
40.             Range("d" & lr).Resize(j - 1) = brr
    
41.         End If
    
42.     Next
    
43.     rs.Close
    
44.     cnn.Close
    
45.     Set rs = Nothing
    
46.     Set cnn = Nothing
    
47. End Sub
    

复制代码

zhaogang1960

下面附件中把一年级分数全部删除了：
按标准提取信息2.5.rar (22.64 KB, 下载次数: 13)

2014-2-5 22:40 上传

点击文件名下载附件

zxc00

zhaogang1960 发表于 2014-2-5 22:41
下面附件中把一年级分数全部删除了：

谢谢，结果不对了，排除没有数据的年级未做到

zhaogang1960

zxc00 发表于 2014-2-5 22:58
谢谢，结果不对了，排除没有数据的年级未做到

请测试33楼附件

zxc00

zhaogang1960 发表于 2014-2-5 23:08
请测试33楼附件

把一年级的补上就不对了

zhaogang1960

zxc00 发表于 2014-2-5 23:13
把一年级的补上就不对了

请上传出错工作簿分析一下

zxc00

zhaogang1960 发表于 2014-2-5 23:15
请上传出错工作簿分析一下

谢谢，请看出错的附件

zhaogang1960

zxc00 发表于 2014-2-5 23:20
谢谢，请看出错的附件

经测试没有发现问题
把一年级的补上后，一年级就有数据了，共有4名200分，他们就是前三名

zxc00

zhaogang1960 发表于 2014-2-5 23:47
经测试没有发现问题
把一年级的补上后，一年级就有数据了，共有4名200分，他们就是前三名

二年级的不对啊，二年级的没有一个达到标准分数的，就排除