gpt4 book ai didi

VBA:从每个类别中提取前 'x' 条目

转载 作者:行者123 更新时间:2023-12-04 20:12:39 27 4
gpt4 key购买 nike

通过简化示例,假设您有以下数据集:

 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

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

有没有更聪明、更清洁的方法来做到这一点?

最佳答案

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

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

tigeravatar example for Will T-E

在单元格 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

关于VBA:从每个类别中提取前 'x' 条目,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/34516441/

27 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com