Question

我有一张这样的表：

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来提高性能吗？

THX siech

Answer 1

您可以尝试以下操作，这会将公式添加到范围中，并且公式只会在带有数据的给定范围中查找，因此不会查看完整的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

Answer 2

试试这个，它没有使用公式，所以它肯定更快。此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

Answer 3

灵感但你的惊人帮助我做了一些微小的改变，可能对其他人有用。对我的更改的评论也非常受欢迎。

添加了工作表dim;
添加了动态列数（最后一列将使用最后一列的最后一列进行更新）;
排除第一行（标题）;

在数组中保存更新，最后只将最后一列写入工作表; （业绩增长只是次要的，预期会更多）;

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

vba值的最大值

3 个答案: