按标准提取信息

zxc00

真厉害，谢谢，祝您 在新的一年里马到成功，行大运，

zxc00

zhaogang1960 发表于 2014-2-2 22:10
可能是3名，也可能多于3名，因为可能有并列名次
请看附件

版主啊，假如每一个年级只要提取前三名呢

zhaogang1960

zxc00 发表于 2014-2-3 21:12
版主啊，假如每一个年级只要提取前三名呢

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) & "' 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 (24.23 KB, 下载次数: 19)

2014-2-3 21:32 上传

点击文件名下载附件

zxc00

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

SQL = "select top 3 班别
这里的3是步长的意思吗

rs.Open SQL, cnn, 1, 3
这里的3是什么意思啊

zhaogang1960

zxc00 发表于 2014-2-3 23:14
SQL = "select top 3 班别
这里的3是步长的意思吗

3是取前3个记录，如果最后一个记录有重复将取其全部
rs.Open SQL, cnn, 1, 3是固定用法，不用管它

zxc00

zhaogang1960 发表于 2014-2-3 23:22
3是取前3个记录，如果最后一个记录有重复将取其全部
rs.Open SQL, cnn, 1, 3是固定用法，不用管它

谢谢，如果不按照标准分数（把标准分数去掉），直接提取前三名呢

zhaogang1960

zxc00 发表于 2014-2-3 23:30
谢谢，如果不按照标准分数（把标准分数去掉），直接提取前三名呢

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 班别 is not null"
   
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 (24.11 KB, 下载次数: 14)

2014-2-3 23:39 上传

点击文件名下载附件

zxc00

zhaogang1960 发表于 2014-2-3 23:39
请测试附件

谢谢您，试试先，