按标准提取信息

zxc00

路过的高手们，新年好，请帮忙写一个代码，谢谢

zhaogang1960

请参考：

1. Private Sub CommandButton2_Click()
   
2.     Dim cnn As Object, rs As Object, SQL$, arr, brr&(), i&, j&, lr&, 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 班别,姓名,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.         ReDim brr(1 To rs.RecordCount, 1 To 1)
    
16.         brr(1, 1) = 1
    
17.         t = rs.Fields(2)
    
18.         rs.MoveNext
    
19.         For j = 2 To rs.RecordCount
    
20.             If rs.Fields(2) = t Then
    
21.                 brr(j, 1) = brr(j - 1, 1)
    
22.             Else
    
23.                 brr(j, 1) = j
    
24.             End If
    
25.             t = rs.Fields(2)
    
26.             rs.MoveNext
    
27.         Next
    
28.         rs.MoveFirst
    
29.         lr = Range("a65536").End(xlUp).Row + 1
    
30.         Range("a" & lr).CopyFromRecordset rs
    
31.         Range("d" & lr).Resize(j - 1) = brr
    
32.     Next
    
33.     rs.Close
    
34.     cnn.Close
    
35.     Set rs = Nothing
    
36.     Set cnn = Nothing
    
37. End Sub
    

复制代码

zhaogang1960

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

2014-2-2 20:55 上传

点击文件名下载附件

zxc00

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

版主，运行不了，中断了

zhaogang1960

zxc00 发表于 2014-2-2 21:21
版主，运行不了，中断了

数据不真实，二年级竟然没有一个合格学生

zhaogang1960

加一个判断，排除没有数据的年级：

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 班别,姓名,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.             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.         End If
    
34.     Next
    
35.     rs.Close
    
36.     cnn.Close
    
37.     Set rs = Nothing
    
38.     Set cnn = Nothing
    
39. End Sub
    

复制代码

zhaogang1960

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

2014-2-2 21:27 上传

点击文件名下载附件

zxc00

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

红色字的要求是，没有达到标准分数的就提取该年级的前三名。

zhaogang1960

zxc00 发表于 2014-2-2 21:50
红色字的要求是，没有达到标准分数的就提取该年级的前三名。

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 班别,姓名,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

可能是3名，也可能多于3名，因为可能有并列名次
请看附件
按标准提取信息.rar (24.88 KB, 下载次数: 34)

2014-2-2 22:09 上传

点击文件名下载附件