一组值的vba最大值答案

【问题标题】：vba max value of group of values一组值的vba最大值
【发布时间】：2018-01-27 14:42:50
【问题描述】：

我有一个这样的表格：

A           B     C
==         ==    ==
groupID1  comp1   1
groupID2  comp2   2
groupID1  comp3   3

我想要实现的是将组的最大值添加到 D 列中的行。在 D 列中遵循 excel 公式给出了我想要的响应：

=INDEX(C:C;SUMPRODUCT(MAX((A:A=A2)*ROW(A:A))))

不幸的是，我的笔记本电脑无法在 50k 行列表中处理此问题。有人可以帮助我使用 vba 以提高性能吗？

谢谢搜索

【问题讨论】：

您在数百万行上执行该操作，而不是 50k，因为您正在使用整个列。仅使用您希望计算的范围 - 如果该范围会发生变化，请查看命名范围或使用适当的表格。
嗨，谢谢您的意见。我尝试限制范围，但没有真正的性能改进： =INDEX($U$2:$U$60000;SUMPRODUCT(MAX(($A$2:$A$60000=A2)*ROW($A$2:$A$60000)) ))

标签： excel vba

【解决方案1】：

试试这个，它不使用公式，所以它肯定更快。这个Sub 将填充 D 列中该组的最大值。

Sub FillGroupsMax()

    Application.ScreenUpdating = False
    'stop screen updating makes vba perform better

    Set last = Range("A:A").Find("*", Cells(1, 1), searchdirection:=xlPrevious)
    'last cell with value in column A

    Dim groupsArray As Variant
    'array with all group infomation
    Dim groupsSeen As Variant
    'array with group infomation already seen

    groupsArray = Range(Cells(1, 1), Cells(last.Row, 3))
    'collect all the information on the Sheet into an array
    'Improves performance by not visiting the sheet

    For dRow = 1 To last.Row
    'for each of the rows

        'check if group as already been seen
        If inArrayValue(Cells(dRow, 1).value, groupsSeen) > 0 Then
            'if it has been seen/calculated attribute value
            Cells(dRow, 4).value = inArrayValue(Cells(dRow, 1).value, groupsSeen)
        Else
            'if it hasn't been seen then find max
            Cells(dRow, 4).value = getMax(Cells(dRow, 1).value, groupsArray)

            'array construction from empty
            If IsEmpty(groupsSeen) Then
                ReDim groupsSeen(0)
                groupsSeen(0) = Array(Cells(dRow, 1).value, Cells(dRow, 4).value)
                'attribute value to array
            Else
                ReDim Preserve groupsSeen(0 To UBound(groupsSeen) + 1)
                groupsSeen(UBound(groupsSeen)) = Array(Cells(dRow, 1).value, Cells(dRow, 4).value)
            End If
        End If
    Next

    'reactivate Screen updating
    Application.ScreenUpdating = True

End Sub

Function getMax(group As String, groupsArray As Variant) As Double

    'for each in array
    For n = 1 To UBound(groupsArray)
        'if its the same group the Max we seen so far the record
        If groupsArray(n, 1) = group And groupsArray(n, 3) > maxSoFar Then
            maxSoFar = groupsArray(n, 3)
        End If
    Next

    'set function value
    getMax = maxSoFar
End Function

Function inArrayValue(group As String, groupsSeen As Variant) As Double

    'set function value
    inArrayValue = 0
    'if array is empty then exit
    If IsEmpty(groupsSeen) Then Exit Function

    'for each in array
    For n = 0 To UBound(groupsSeen)
        'if we find the group
        If groupsSeen(n)(0) = group Then
            'set function value to the Max value already seen
            inArrayValue = groupsSeen(n)(1)
            'exit function earlier
            Exit Function
        End If
    Next

End Function

【讨论】：

这很好用！ thx，永远不会想到这一点。非常感谢您的帮助。

【解决方案2】：

您可以尝试以下操作，这会将公式添加到范围中，并且公式只会在给定范围内查找数据，因此不会查看完整的 A 列，它只会查找到最后一行的数据：

Sub foo()
    Dim ws As Worksheet: Set ws = Sheets("Sheet1")
    'declare and set your worksheet, amend as required
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    'get the last row with data on Column A

    Set Rng = ws.Range("D1:D" & LastRow) 'set the range where you want your formula
    Rng.FormulaR1C1 = "=INDEX(R1C3:R" & LastRow & "C3,SUMPRODUCT(MAX((R1C1:R" & LastRow & "C1=RC[-3])*ROW(R1C1:R" & LastRow & "C1))))""
    'add the formula to the range
End Sub

【讨论】：

【解决方案3】：

启发，但你的惊人帮助我做了一些可能对其他人有用的小改动。也欢迎对我的更改发表评论。

添加了工作表暗淡；
添加了动态列数（最后一列将更新为前一列的最大值）；
排除第一行（标题）；

将更新保存在数组中，最后只将最后一列写入工作表；（性能提升很小，预计会更多）；

Sub FillGroupsMax()
    Dim lColumn As Long
    Dim sht As Worksheet
    Dim groupsArray As Variant    'array with all group infomation
    Dim groupsSeen As Variant    'array with group infomation already seen

    Application.ScreenUpdating = False    'stop screen updating makes vba perform better

    Set sht = ThisWorkbook.Worksheets("import")
    Set last = sht.Range("A:A").Find("*", Cells(1, 1), searchdirection:=xlPrevious)    'last cell with value in column A
    lColumn = sht.Cells(1, Columns.Count).End(xlToLeft).Column

    groupsArray = sht.Range(Cells(1, 1), Cells(last.Row, lColumn))
    'collect all the information on the Sheet into an array
    'Improves performance by not visiting the sheet

    For dRow = 2 To last.Row    'for each of the rows skipping header

        'check if group as already been seen
        If inArrayValue(Cells(dRow, 1).Value, groupsSeen) > 0 Then
            'if it has been seen/calculated attribute value
            'Cells(dRow, 4).Value = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
            groupsArray(dRow, lColumn) = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
        Else
            'if it hasn't been seen then find max
            'Cells(dRow, 4).Value = getMax(Cells(dRow, 1).Value, groupsArray)
            groupsArray(dRow, lColumn) = getMax(Cells(dRow, 1).Value, groupsArray, lColumn)

            'array construction from empty
            If IsEmpty(groupsSeen) Then
                ReDim groupsSeen(0)
                'groupsSeen(0) = Array(Cells(dRow, 1).Value, Cells(dRow, 4).Value)
                groupsSeen(0) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
                'attribute value to array
            Else
                ReDim Preserve groupsSeen(0 To UBound(groupsSeen) + 1)
                groupsSeen(UBound(groupsSeen)) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
            End If
        End If
    Next

sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
    'reactivate Screen updating
    Application.ScreenUpdating = True

End Sub

Function getMax(group As String, groupsArray As Variant, lColumn As Long) As Double

    'for each in array
    For n = 1 To UBound(groupsArray)
        'if its the same group the Max we seen so far the record
        If groupsArray(n, 1) = group And groupsArray(n, lColumn - 1) > maxSoFar Then
            maxSoFar = groupsArray(n, lColumn - 1)
        End If
    Next

    'set function value
    getMax = maxSoFar
End Function

Function inArrayValue(group As String, groupsSeen As Variant) As Double

    'set function value
    inArrayValue = 0
    'if array is empty then exit
    If IsEmpty(groupsSeen) Then Exit Function

    'for each in array
    For n = 0 To UBound(groupsSeen)
        'if we find the group
        If groupsSeen(n)(0) = group Then
            'set function value to the Max value already seen
            inArrayValue = groupsSeen(n)(1)
            'exit function earlier
            Exit Function
        End If
    Next

End Function

【讨论】：