adodb 提取各科最高分记录

foreversun

提取最高分所在的记录。 详情在附件中
With CreateObject("ADODB.Connection")
            .Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes;';data source=" & ThisWorkbook.FullName
                         [i14].CopyFromRecordset .Execute("Select  *   From   (Select   Top   1   Name,   English   As   Score,   'English '   As   Course     From   [sheet1$a1:q100] Order   By   Score   Desc   )  A Union All   Select     *   From   (Select   Top   1   Name,   Chinese   As   Score,   'Chinese'   As   Course     From   [sheet1$a1:q100]    Order   By   Score   Desc   )   A Union All Select     *   From   (Select   Top   1   Name,   Math   As   Score,   'Math'   As   Course     From  [sheet1$a1:q100]    Order   By   Score   Desc   )   A")
            .Close
                   End With
出 记录.rar (8.13 KB, 下载次数: 79)

2012-10-1 12:26 上传

点击文件名下载附件

错了。
select ""中的根据：http://topic.csdn.net/u/20070322/00/fd80a717-8fa3-4097-b3dd-86e22141f3c0.html改的，不知为何不对。

mjzxlmg

Sub test()
Dim arr, i&, j&, m&
arr = Sheet1.[a1].CurrentRegion.Value
ReDim brr(1 To UBound(arr, 2) - 2, 1 To 5)
For j = 2 To UBound(arr, 2) - 1
    m = m + 1
    brr(m, 1) = arr(1, j)
    For i = 2 To UBound(arr)
        If brr(m, 3) = "" Then
            brr(m, 2) = arr(2, 1)
            brr(m, 3) = arr(2, j)
            brr(m, 4) = arr(2, UBound(arr, 2) - 1)
            brr(m, 5) = arr(2, UBound(arr, 2))
        End If
        If arr(i, j) > brr(m, 3) Then
            brr(m, 2) = arr(i, 1)
            brr(m, 3) = arr(i, j)
            brr(m, 4) = arr(i, UBound(arr, 2) - 1)
            brr(m, 5) = arr(i, UBound(arr, 2))
        End If
    Next
Next
Sheet1.[h4].Resize(m, 5).Value = brr
End Sub

foreversun

有用sql方法解决的吗。

foreversun

foreversun 发表于 2012-10-1 18:43
有用sql方法解决的吗。

希望能有sqL的解决办法

zhaogang1960

请参考：

1. select 'English',Name,English as 分数,zf,rank from [Sheet1$A1:F15] where English=(select max(English) from [Sheet1$A1:F15]) Union All select 'Chinese',Name,Chinese as 分数,zf,rank from [Sheet1$A1:F15] where Chinese=(select max(Chinese) from [Sheet1$A1:F15]) Union All select 'Math',Name,Math as 分数,zf,rank from [Sheet1$A1:F15] where Math=(select max(Math) from [Sheet1$A1:F15]) Union All select 'zf',Name,zf as 分数,zf,rank from [Sheet1$A1:F15] where zf=(select max(zf) from [Sheet1$A1:F15])

复制代码

zhaogang1960

VBA代码请参考：

1. Sub Macro1()
   
2.     Dim cnn As Object,  SQL$, arr, i&, t$, s$
   
3.     Set cnn = CreateObject("ADODB.Connection")
   
4.     arr = Sheets("Sheet1").Range("b1:e1")
   
5.     t = "[Sheet1$" & Sheets("Sheet1").[a1].CurrentRegion.Address(0, 0) & "]"
   
6.     For i = 1 To UBound(arr, 2)
   
7.         If i = 1 Then
   
8.             SQL = "select '" & arr(1, i) & "',Name," & arr(1, i) & " as 分数,zf,rank from " & t & " where " & arr(1, i) & "=(select max(" & arr(1, i) & ") from " & t & ")"
   
9.         Else
   
10.             SQL = SQL & " Union All select '" & arr(1, i) & "',Name," & arr(1, i) & " as 分数,zf,rank from " & t & " where " & arr(1, i) & "=(select max(" & arr(1, i) & ") from " & t & ")"
    
11.         End If
    
12.     Next
    
13.     cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
    
14.     Range("H4:L65536").ClearContents
    
15.     Range("h4").CopyFromRecordset cnn.Execute(SQL)
    
16.     cnn.Close
    
17.     Set cnn = Nothing
    
18. End Sub

复制代码

foreversun

版主出手，果然不同。