excel - 使用 VBA 从已排序的列中选择最高/最低 n 值

问题描述

我有一个包含 12 列 (A:J) 的表，第 11 列包含用户分数，第 12 列包含用户排名。我创建了一个单独的子来根据需要对数据进行排序。我正在尝试创建一个新的子以在排序子之后运行，该子将选择最高和最低的 n（例如 3）值，然后将关联的行粘贴到同一工作簿中的单独工作表中。

可以在此处查看数据集的示例：

我是 VBA 和编程的新手。任何帮助，将不胜感激。以前在这里已经回答了类似的问题，但是相关的代码和解释并不能引导我得到想要的结果。

编辑：

如果多个用户获得相同的分数，我想选择所有得分最高/最低 n 的用户。

原始代码由@tigeravatar在这里发布。

在下面的评论中添加几种用户提到的代码：

Extract Top 'x' Entries from each category

Sub Top 3 values()

    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rngData As Range
    Dim rngFound As Range
    Dim rngUnqGroups As Range
    Dim GroupCell As Range
    Dim lCalc As XlCalculation
    Dim aResults() As Variant
    Dim aOriginal As Variant
    Dim lNumTopEntries As Long
    Dim i As Long, j As Long, k As Long

    'Change to grab the top X number of entries per category'
    lNumTopEntries = 3

    Set wsData = ActiveWorkbook.Sheets("Data")    'This is where your data is'
    Set wsDest = ActiveWorkbook.Sheets("National")    'This is where you want to output it'

    Set rngData = wsData.Range("A1", wsData.Cells(Rows.Count, "A:M").End(xlUp))
    aOriginal = rngData.Value   'Store original values so you can set them back later'

    'Turn off calculation, events, and screenupdating'
    'This allows code to run faster and prevents "screen flickering"'
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    'If there are any problems with the code, make sure the calculation, events, and screenupdating get turned back on'
    On Error GoTo CleanExit

    With rngData
        .Sort .Resize(, 1).Offset(, 1), xlAscending, .Resize(, 1).Offset(, 2), , xlDescending, Header:=xlYes
    End With

    With rngData.Resize(, 1).Offset(, 1)
        .AdvancedFilter xlFilterInPlace, , , True
        Set rngUnqGroups = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        .Parent.ShowAllData 'Remove the filter

        ReDim aResults(1 To rngUnqGroups.Cells.Count * lNumTopEntries, 1 To 3)
        i = 0

        For Each GroupCell In rngUnqGroups
            Set rngFound = .Find(GroupCell.Value, .Cells(.Cells.Count))
            k = 0
            If Not rngFound Is Nothing Then
                For j = i + 1 To i + lNumTopEntries
                    If rngFound.Offset(j - i - 1).Value = GroupCell.Value Then
                        k = k + 1
                        aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
                        aResults(j, 2) = rngFound.Offset(j - i - 1).Value
                        aResults(j, 3) = rngFound.Offset(j - i - 1, 1).Value
                    End If
                Next j
                i = i + k
            End If
        Next GroupCell
    End With

    'Output results'
    wsDest.Range("A2").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults

CleanExit:
    'Turn calculation, events, and screenupdating back on'
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    If Err.Number <> 0 Then
        'There was an error, show the error'
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If

    'Put data back the way it was
    rngData.Value = aOriginal

End Sub

标签： excelvba

excel - 使用 VBA 从已排序的列中选择最高/最低 n 值

问题描述

解决方案

推荐阅读