在组中查找最大值并使用VBA复制整行

Question

我想找到一个组中的最大值（分组依据：A列，最大值：E列）并将整个原始值复制到excel中的下一个工作表。

A-B-C-d-E

1-10-4-2-5.491

1-10-5-2-5.8

1-20-4-3-4.498

2-30-5-3-6.663

2-30-6-4-8.205

2-10-4-5-8.562

3-10-5-6-7.026

3-30-7-2-10.665

3-30-8-2-8.472

4-10-4-1-4.489

4-10-5-1-5.491

4-25-7-3-0.816

我的期望是在另一张表中获得如下输出。

1-10-5-2-5.8

2-10-4-5-8.562

3-30-7-2-10.665

4-10-5-1-5.491

请建议一个解决方案。（首选在VBA中有解决方案）谢谢。

Answer 1

在F列中添加辅助公式，将其称为“max”或其他，然后将此数组公式放在第一个数据行中（我假设第2行）：

=E2=MAX(IF(A2=$A$2:$A$13,$E$2:$E$13))

注意，按Ctrl + Shift + Enter（不仅仅是Enter）需要提交数组公式。

填写公式。

您现在有一列TRUE / FALSE值。自动过滤此列并选择TRUE。

将结果复制并粘贴到新工作表中。

Answer 2

这是一个基于VBA的解决方案，它构建了以下内容：

Option Explicit
Sub FindMaximums()

Dim DataSheet As Worksheet, MaxSheet As Worksheet
Dim LastDataRow As Long, GroupCol As Long, _
    MeasureCol As Long, CurrentGroup As Long, _
    MaxMeasureRow As Long, RowIdx As Long, _
    LastMaxRow As Long
Dim MaxMeasureValue As Double
Dim DataRng As Range, MaxRng As Range

'identify sheets and columns for easy reference
Set DataSheet = ThisWorkbook.Worksheets("Data")
Set MaxSheet = ThisWorkbook.Worksheets("Maximums")
GroupCol = 1 'grouping info in column A
MeasureCol = 5 'measure for comparison in column E

'identify the last row to set bounds on our loop
LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

'initialize group and max variables
CurrentGroup = 1
MaxMeasureValue = 0
MaxMeasureRow = 1
LastMaxRow = 1

'loop through all rows
For RowIdx = 2 To LastDataRow

    'check to see if there has been a group change
    If DataSheet.Cells(RowIdx, GroupCol).Value > CurrentGroup Then

        'write out the max measure row
        Set DataRng = Range(DataSheet.Cells(MaxMeasureRow, GroupCol), DataSheet.Cells(MaxMeasureRow, MeasureCol))
        Set MaxRng = Range(MaxSheet.Cells(LastMaxRow, GroupCol), MaxSheet.Cells(LastMaxRow, MeasureCol))
        DataRng.Copy MaxRng

        'initialize and increment
        CurrentGroup = DataSheet.Cells(RowIdx, GroupCol).Value
        MaxMeasureValue = 0
        MaxMeasureRow = 1
        LastMaxRow = LastMaxRow + 1

    End If

    'evaluate max measure logic
    If DataSheet.Cells(RowIdx, MeasureCol).Value > MaxMeasureValue Then
        MaxMeasureValue = DataSheet.Cells(RowIdx, MeasureCol).Value
        MaxMeasureRow = RowIdx
    End If

Next RowIdx

'write out the last maximums
Set DataRng = Range(DataSheet.Cells(MaxMeasureRow, GroupCol), DataSheet.Cells(MaxMeasureRow, MeasureCol))
Set MaxRng = Range(MaxSheet.Cells(LastMaxRow, GroupCol), MaxSheet.Cells(LastMaxRow, MeasureCol))
DataRng.Copy MaxRng

End Sub