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。然后我还想要 B 组和 C 组的最高两个条目。

我希望 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

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

有没有更聪明、更简洁的方法？

Answer 1

这必须是 VBA 吗？可以用公式来完成。

根据您提供的示例数据，您可以像这样设置 Sheet2：

在 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 单元格中并复制下来是这个公式：

=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

Answer 2

这样的事情应该可以工作：

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") 和 Range("A" & 2 * i) 反映了你的 x 值，在这个例子中你说的是 2。因此 vba 复制行 2:3 并将它们粘贴到新工作表中的行 2*i 中。