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

举个简单的例子，假设你有以下数据集：

ABC 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，我们也希望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 

总之，我只是从Largest到最小的值进行sorting，然后对每个组进行筛选，并提取前两个值。 但是，代码不具有弹性，因为复制部分依赖于特定顺序的名称，当我获得新数据时这些名称将会改变。

有一个更聪明，更干净的方式做到这一点？

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行2*i中的新表中。