按名次提取数据到新表

SCWYZJ

我有一个表，我想实现按名次一键提取最前和最后三名（或更多）的数据到对应表中，请教各位老师帮我看看怎样写vb代码，谢谢！

曹银强

Sub TEST()
Set CN = CreateObject("ADODB.CONNECTION")
CN.Open "PROVIDER=MICROSOFT.JET.OLEDB.4.0;EXTENDED PROPERTIES=EXCEL 8.0;DATA SOURCE=" & ThisWorkbook.FullName
Sql = "SELECT top 3 * FROM [数据源$] ORDER BY 分数 DESC"
Sheets("最前三名").Range("A3").CopyFromRecordset CN.Execute(Sql)
SqlL = "SELECT top 3 * FROM [数据源$] ORDER BY 分数 ASC"
Sheets("最后三名").Range("A3").CopyFromRecordset CN.Execute(SqlL)
End Sub

曹银强

见附件--------

任飘渺

Sub 前三名()
Dim i As Integer, endrow As Integer
    With Sheet1
        .Range("a:c").Sort key1:=.[c1], order1:=xlAscending, Header:=xlYes
        endrow = .Range("a1").CurrentRegion.Rows.Count
        If .Cells(5, 3).Value = "4" Then
            Sheet2.Range("a7").Resize(3, 3).Value = .Range("a2").Resize(3, 3).Value
        Else
            For i = 6 To endrow
                If Cells(i, 3).Value = 4 Then
                    Sheet2.Range("a7").Resize(i - 2, 3).Value = .Range("a2").Resize(i - 2, 3).Value
                    Exit For
                End If
            Next i
        End If
    End With
Sheet2.Activate
End Sub
Sub 后三名()
Dim i As Integer, endrow As Integer, x
    With Sheet1
        .Range("a:c").Sort key1:=.[c1], order1:=xlDescending, Header:=xlYes
        endrow = .Range("a1").CurrentRegion.Rows.Count
        x = .Cells(2, 3).Value - 3
        If .Cells(5, 3).Value = x Then
            Sheet3.Range("a8").Resize(3, 3).Value = .Range("a2").Resize(3, 3).Value
        Else
            For i = 6 To endrow
                If Cells(i, 3) = x Then
                    Sheet3.Range("a11").Resize(i - 2, 3).Value = .Range("a2").Resize(i - 2, 3).Value
                    Exit For
                End If
            Next i
        End If
    End With
Sheet3.Activate
End Sub

duquancai

Sub test()
    Dim O(2) As Object, Ar, s$, a(), b()
    Application.ScreenUpdating = False
    Set O(0) = CreateObject("htmlfile"): Set O(1) = O(0).parentWindow
    Sheets("数据源").Select
    Ar = Range("a2:c" & Cells(Rows.Count, 1).End(3).Row)
    Set O(2) = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Ar)
        If Not O(2).exists(Ar(i, 3)) Then
            ReDim a(0)
        Else
            a = O(2)(Ar(i, 3))
            ReDim Preserve a(UBound(a) + 1)
        End If
        a(UBound(a)) = i: O(2)(Ar(i, 3)) = a
    Next
    k = O(2).keys: s = "[""" & Join(k, """,""") & """]"
    O(1).execScript "a=" & s & ";function sortAr(m,n){return m-n};a.sort(sortAr)"
    k = Split(O(1).eval("a"), ",")
    Sheets("最前三名").[a3:c1000] = ""
    r = Sheets("最前三名").Cells(Sheets("最前三名").Rows.Count, 1).End(3).Row + 1
    ReDim a(1 To 100, 1 To UBound(Ar, 2))
    For i = 0 To 2
        For j = 0 To UBound(O(2)(Val(k(i))))
            n = n + 1
            For x = 1 To UBound(Ar, 2)
                a(n, x) = Ar(O(2)(Val(k(i)))(j), x)
            Next
        Next
    Next
    Sheets("最前三名").Range("a" & r).Resize(n, 3) = a
    Sheets("最后三名").[a3:c1000] = ""
    r = Sheets("最后三名").Cells(Sheets("最后三名").Rows.Count, 1).End(3).Row + 1
    ReDim b(1 To 100, 1 To UBound(Ar, 2))
    For i = UBound(k) To UBound(k) - 2 Step -1
        For j = 0 To UBound(O(2)(Val(k(i))))
            m = m + 1
            For x = 1 To UBound(Ar, 2)
                b(m, x) = Ar(O(2)(Val(k(i)))(j), x)
            Next
        Next
    Next
    Sheets("最后三名").Range("a" & r).Resize(m, 3) = b
    Application.ScreenUpdating = True
    MsgBox "ok!"
End Sub

SCWYZJ

duquancai  任飘渺  曹银强  三位老师的代码都可以，但是只能运行1次，不能重复执行。我要的是可以重复执行，达到可追加数据的效果！另外，我有一个表，麻烦各位老师，顺便帮我改改代码（见附件）谢谢了！

SCWYZJ

最好是在追加数据的时候，添加上边框线及位置居中更好！

SCWYZJ

今天我有试了一下，三位老师的代码，发现duquancai老师的代码在删除清空工作表区域的代码后，可以满足我的要求！所以我的分给他，也非常感谢其他两位老师的帮助！