I have a table formated like this:
A B C
== == ==
groupID1 comp1 1
groupID2 comp2 2
groupID1 comp3 3
what I want to achieve is to have the max value of the group added to the line in column D. Following excel formula in column D gives the response I want:
=INDEX(C:C;SUMPRODUCT(MAX((A:A=A2)*ROW(A:A))))
unfortunately my laptop cannot handle this on a list of 50k lines. can somebody help me out with vba to make it more performant?
thx siech
You could try the following, this will add the formula to the range, and the formula will only look in the give range with data, so instead of looking at the full Column A it will only look until the last row with data:
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
Try this, it doesn't use formulas so its definitely faster.
This Sub will fill the Max for that group in column 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
inspired but your amazing help I made some minor changes that could maybe be useful for others. Comments on my changes also most welcome.
save updates in array and only write last column to sheet at the end; (performance increase was only minor, would have expected more);
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
