查找组内的最大值，并使用VBA复制整个行 [英] Find Max Value within a group and copy entire row using VBA

问题描述

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

ABCDE

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中有解决方案）谢谢。

解决方案

这是一个基于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 
 
'和列以便于参考
设置DataSheet = ThisWorkbook.Worksheets（Data）
设置MaxSheet = ThisWorkbook.Worksheets（Maximums）
 GroupCol = 1'在A列中分组信息
 MeasureCol = 5'在列E中比较的度量
 
'标识最后一行在我们的循环上设置边界
 LastDataRow = DataSheet.Cells.Find（*，SearchOrder = xlByRows，SearchDirection：= xlPrevious）.Row 
 
'初始化组和最大变量
 CurrentGroup = 1 
 MaxMeasureValue = 0 
 MaxMeasureRow = 1 
 LastMaxRow = 1 
 
'循环遍历所有行
对于RowIdx = 2 To LastDataRow 
 
'检查是否有组更改
如果DataSheet.Cells（RowIdx，GroupCol）.Value> CurrentGroup然后
 
'写出最大测量行
设置DataRng = Range（DataSheet.Cells（MaxMeasureRow，GroupCol）），DataSheet.Cells（MaxMeasureRow，MeasureCol））
设置MaxRng =范围（MaxSheet.Cells（LastMaxRow，GroupCol），MaxSheet.Cells（LastMaxRow，MeasureCol））
 DataRng.Copy MaxRng 
 
'初始化和增量
 CurrentGroup = DataSheet.Cells （RowIdx，GroupCol）.Value 
 MaxMeasureValue = 0 
 MaxMeasureRow = 1 
 LastMaxRow = LastMaxRow + 1 
 
如果
 
'评估最大测量逻辑
如果DataSheet.Cells（RowIdx，MeasureCol）.Value> MaxMeasureValue然后
 MaxMeasureValue = DataSheet.Cells（RowIdx，MeasureCol）.Value 
 MaxMeasureRow = RowIdx 
如果
 
下一个RowIdx 
 
'写出最后的最大值
设置DataRng = Range（DataSheet.Cells（MaxMeasureRow，GroupCol），DataSheet.Cells（MaxMeasureRow，MeasureCol））
设置MaxRng = Range（MaxSheet.Cells（LastMaxRow，GroupCol）最大值
I want to find the max value within a group (group by:Column A , max value : column E) and copy entire raw to a next sheet in 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

My expectation is to get the output as below in another sheet.

1-10-5-2-5.8

2-10-4-5-8.562

3-30-7-2-10.665

4-10-5-1-5.491

Please suggest a solution.(preferred to have a solution in VBA)Thanks.
解决方案
Here is a VBA-based solution which builds the following:

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


                        
这篇关于查找组内的最大值，并使用VBA复制整个行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！