VBA：从每个类别中提取顶部'x'条目

Question

简化示例的方式，说您有以下数据集：

 A      B     C
Name  Group Amount
Dave    A     2
Mike    B     3
Adam    C     4
Charlie A     2
Edward  B     5
Fiona   B     5
Georgie A     4
Harry   C     1
Mary    A     0
Delia   A     0
Victor  B     1
Dennis  B     0
Erica   A     4
Will    B     4

我正在尝试从每个组中提取最高的“ x”条目（在此示例中说2）。

，例如，A组中最高的两个条目是Georgie和Erica 4。

我希望VBA代码提取这些行并将其粘贴到另一个工作表上以进行后续分析。

到目前为止，我已经尝试了这样的代码：

ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _
    ("C1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
ActiveSheet.Range("$A$1:$C$15").AutoFilter Field:=2, Criteria1:="A"
Range("A5:C6").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
ActiveSheet.Range("$A$1:$C$15").AutoFilter Field:=2, Criteria1:="B"
Range("A2:C3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("E2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
ActiveSheet.Range("$A$1:$C$15").AutoFilter Field:=2, Criteria1:="C"
Range("A4:C11").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("I2").Select
ActiveSheet.Paste

简而言之，我只是将值从最大到最小的，然后为每个组进行过滤，然后提取顶部两个值。但是，代码没有弹性，因为复制部分取决于以特定顺序的名称，在我获取新数据时会更改。

有一种更聪明，更干净的方式吗？
    

这一定是VBA吗？可以使用公式完成。

基于提供的示例数据，您可以这样设置Sheep2：

Answer 1

中的细胞a4并复制了这个公式：

=IF($C4="","",INDEX(Sheet1!$A$2:$A$15,MATCH(1,INDEX((Sheet1!$B$2:$B$15=$B4)*(Sheet1!$C$2:$C$15=$C4)*(COUNTIFS($A$3:$A3,Sheet1!$A$2:$A$15,$B$3:$B3,$B4)=0),),0))) 中的细胞B4并复制为此公式：

=IF(($B$1>0)*COUNT($B$1),IF(OR($B3="Group",COUNTIF($B$3:$B3,$B3)=$B$1),IFERROR(INDEX(Sheet1!$B$2:$B$15,MATCH(0,INDEX(COUNTIF($B$3:$B3,Sheet1!$B$2:$B$15),),0)),""),$B3),"")

中C4并将其复制为DOWN是该公式：

=IF(OR($B4="",COUNTIF(Sheet1!$B$2:$B$15,$B4)<COUNTIF($B$4:$B4,$B4)),"",LARGE(INDEX(Sheet1!$C$2:$C$15*(Sheet1!$B$2:$B$15=$B4),),COUNTIF($B$4:$B4,$B4)))

注意，您可以将这些公式将其复制到相当多的方式，并且只会显示所需的结果。  额外的行只会空白。  您还可以将B1中的数字更改为无论是最高条目的数量，因此您可以看到每个类别的前5名或前3名，等等。

，但是，如果绝对必须是VBA，那么类似的东西应该对您有用。 它并不简单，但是非常有效且灵活。 您需要做的就是更新

lNumTopEntries

，您的工作表名以及数据所在的位置：Set rngData

像这样的东西应该起作用：

Sub tgr()

    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 = 2

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

    Set rngData = wsData.Range("A1", wsData.Cells(Rows.Count, "C").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

Sub TopValues()

Dim sht As Worksheet
Dim StartCell As Range

Set sht = Worksheets("Sheet1")
Set StartCell = Range("A1")

Set SrcRange = StartCell.CurrentRegion
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Data"
For i = 1 To 3
    SrcRange.Sort Key1:=Worksheets("Sheet1").Range("A1").Offset(0, i - 1), Order1:=xlAscending, Header:=xlYes
    sht.Rows("2:3").EntireRow.Copy
    Worksheets("Data").Activate
    ActiveSheet.Range("A" & 2 * i).PasteSpecial
Next i


End Sub

和

Rows("2:3")

Answer 2

Range("A" & 2 * i)

，并将它们粘贴在新纸上。

如果我替换出小功能，则无法获得结果 请帮助