VBA 按“并列排名”提取前10名的问题——只能提取到前10行

zglibk

各位老师好，感谢关注！
            1、我的一张“汇总”表，需要按标题栏“次数”的各行数据降序提取前十名（所有次数相同的并列一个名次），目前运行的结果只能取前十行，不能实现取并列名次的效果
         2、今天换了一台电脑运行的时候出现
   希望帮忙纠正、补充，以实现
        1、降序，取并列排名前十
        2、相应位置标上排名的名次
  具体的请见附件~ 提取前10（并列排名）问题.rar (17.15 KB, 下载次数: 27)

2018-4-23 19:29 上传

点击文件名下载附件

附件中的代码如下：
Private Sub CommandButton1_Click()
     Dim cnn As Object, sql$, rs As Object
    Sheet12.Range("F6:H" & Rows.Count).ClearContents
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;';data source=" & ActiveWorkbook.FullName
    sql = "select top 10 名称,次数,金额 from [汇总$A5:C] order by 次数 desc"
    Set rs = cnn.Execute(sql)
    Sheet12.[F6].CopyFromRecordset rs
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

'今天换了一台电脑运行的时候又出现错误提示——'Open'作用于对象'_Connection'时失败~    ///不知何故

看见星光

Private Sub CommandButton1_Click()
    Dim cnn As Object, sql$, rs As Object
    Sheet12.Range("F6:H" & Rows.Count).ClearContents
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;';data source=" & ActiveWorkbook.FullName
    sql = "(select min(次数) from (select top 10 次数 from [汇总$A5:C] group by [次数] order by 次数 desc) )"
    sql = "select 名称,次数,金额 from [汇总$A5:C] where 次数>= " & sql & " order by 次数 desc"
    Set rs = cnn.Execute(sql)
    arr = rs.getrows
    ReDim brr(0 To UBound(arr, 2), 0 To UBound(arr) + 1)
    For i = 0 To UBound(brr)
        For j = 1 To UBound(brr, 2)
            brr(i, j) = arr(j - 1, i)
        Next
        If i = 0 Then
            brr(i, 0) = 1
        ElseIf brr(i, 2) < brr(i - 1, 2) Then
            brr(i, 0) = brr(i - 1, 0) + 1
        Else
            brr(i, 0) = brr(i - 1, 0)
        End If
    Next
    [e6].Resize(UBound(brr) + 1, UBound(brr, 2) + 1) = brr
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

看见星光

提取前10（并列排名）问题.rar (20.39 KB, 下载次数: 169)

2018-4-23 20:59 上传

点击文件名下载附件

jiminyanyan

Sub jimin()
  Dim r As Integer
  Dim i As Integer
  Dim arr, brr(1 To 100, 1 To 4)
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  With Worksheets("汇总")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("a5:c" & r)
    For i = 2 To UBound(arr)
      If Not d.exists(arr(i, 2)) Then
         m = m + 1
         n = n + 1
          If m > 10 Then
            Exit For
         End If
         brr(n, 1) = m
         brr(n, 2) = arr(i, 1)
         brr(n, 3) = arr(i, 2)
         brr(n, 4) = arr(i, 3)
         d(arr(i, 2)) = m
        Else
         n = n + 1
          brr(n, 1) = d(arr(i, 2))
          brr(n, 2) = arr(i, 1)
          brr(n, 3) = arr(i, 2)
          brr(n, 4) = arr(i, 3)
        End If
    Next
    .Range("e6:h100").ClearContents
    .Range("e6").Resize(UBound(brr), UBound(brr, 2)) = brr
  End With
End Sub

jiminyanyan

。。。。。。。。。

zglibk

非常感谢@Power BI和q494585639两位老师的热心帮助！
两种查找提取的方法都在这里学习啦，真是条条道路通罗马~

LMY123

arr = rs.getrows