按标准提取信息

zxc00

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

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

zhaogang1960

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

请看28楼要求：

zxc00

zhaogang1960 发表于 2014-2-6 00:05
请看28楼要求：

不好意思。这个又是一个新的要求了 ：：按上面的标准分数，达到标准分数的提取前三名，排除没有数据的年级

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 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.             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

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

2014-2-6 00:12 上传

点击文件名下载附件

zxc00

zhaogang1960 发表于 2014-2-6 00:11

谢谢，辛苦了，不好意思多次麻烦您/

zxc00

zhaogang1960 发表于 2014-2-6 00:12
请看附件

ado怎么学习的啊，好劲哦

yjh_27

参见附件。

zxc00

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

第10楼的代码能做成加载宏吗，如果可以的话，请也把过程详细地说说或者制作过程的视频更好，谢谢

zhaogang1960

zxc00 发表于 2014-2-8 21:23
第10楼的代码能做成加载宏吗，如果可以的话，请也把过程详细地说说或者制作过程的视频更好，谢谢

在ThisWorkbook加菜单代码，把主程序放在模块中，另存为加载宏即可：

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2.     On Error Resume Next
   
3.     Application.CommandBars(1).Controls("按标准提取信息").Delete
   
4. End Sub
   
5. 
   
6. Private Sub Workbook_Open()
   
7.     Dim CtrButton As CommandBarControl
   
8.     Set CtrButton = Application.CommandBars(1).Controls.Add(Type:=10, before:=11)
   
9.     With CtrButton
   
10.         .Caption = "按标准提取信息"
    
11.         With CtrButton.Controls.Add(Type:=1)
    
12.             .Caption = "按标准提取信息"
    
13.             .OnAction = "按标准提取信息"
    
14.         End With
    
15.     End With
    
16. End Sub
    

复制代码

模块：

1. Sub 按标准提取信息()
   
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 =" & ActiveWorkbook.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
    
44. 
    

复制代码