组内寻找最大价值，并复制使用VBA

我想找到一个组内的最大值整行（按：列A，最大值：列E）和复制整个原材料到下表中的Excel。组内寻找最大价值，并复制使用VBA

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的溶液）谢谢。

来源

2014-04-03 user3494938

'请提出一个solution' - 你尝试过什么？询问代码的问题必须证明对所解决问题的最小理解。包括尝试解决方案，为什么他们没有工作，以及预期的结果。 –

Dan Wagner使用VBA给出的正确答案。 – user3494938

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

start_to_finish

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

来源

2014-04-04 01:35:08

我试过你的建议，Im即使在表名更改为“DataSheet.Cells（RowIdx，GroupCol）.Value”数据”。请帮忙。 – user3494938

Hey @ user3494938，我上面写的例程依赖于“Group”值在列A中，“Measure”值在列E中，如屏幕截图所示。你的数据看起来像那样吗？ –

你的代码工作..一个很好的解决方案。 – user3494938

F栏添加一个辅助公式，把它称为“最大”或什么，然后把这个数组公式的第一个数据行（我假设第2行）：

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

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

填写公式。

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

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

来源

2014-04-03 23:06:26

您的建议有效。谢谢。但我宁愿有一个VBA解决方案。 – user3494938

+1 @ andy-holaday，内置的功能是这样的问题很好看 –

组内寻找最大价值，并复制使用VBA

回答

相关问题