Sub DreyFoxV1()
'
Dim Average As Double, Column_A_NameMaxValue As Double, Column_A_NameMinValue As Double
Dim ArrayLoop As Long, Lastrow As Long, ResultsCount As Long
Dim Column_A_Name As String, NewCheck As String
Dim AverageArray() As Variant, SortedRangeArray() As Variant
'
Lastrow = Range("A" & Rows.Count).End(xlUp).Row ' Get row number of last row of data
'
Range("A1:B" & Lastrow).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo ' Sort data range by column A just in case it is not sorted
'
SortedRangeArray = Range("A1:B" & Lastrow) ' Load data from columns A & B into 2D 1 based SortedRangeArray ... RC
ReDim AverageArray(1 To UBound(SortedRangeArray), 1 To 2) ' Resize the AverageArray
'
Column_A_Name = vbNullString ' Initialize Column_A_Name that will be saved
Column_A_NameMaxValue = 0 ' Initialize Column_A_NameMaxValue
Column_A_NameMinValue = 0 ' Initialize Column_A_NameMinValue
ResultsCount = 0 ' Initialize ResultsCount
NewCheck = "YES" ' Initialize NewCheck flag that indicates if a new name has been found
'
For ArrayLoop = 1 To UBound(SortedRangeArray) ' Loop to check for unique names and values (high & low)
If NewCheck = "YES" Then ' If expected new name then ...
Column_A_Name = SortedRangeArray(ArrayLoop, 1) ' Save the new name
Column_A_NameMaxValue = SortedRangeArray(ArrayLoop, 2) ' Save the value found as Column_A_NameMaxValue
Column_A_NameMinValue = SortedRangeArray(ArrayLoop, 2) ' Save the value found as Column_A_NameMinValue
'
NewCheck = "NO" ' Set the NewCheck flag to indicate we have new name saved
ResultsCount = ResultsCount + 1 ' Increment ResultsCount
GoTo NextCheck ' Skip other checks and loop back
Else ' Else ...
If SortedRangeArray(ArrayLoop, 1) = Column_A_Name Then ' If name = saved name then ... Match found ;)
If SortedRangeArray(ArrayLoop, 2) > Column_A_NameMaxValue Then ' If value found > saved max value then ...
Column_A_NameMaxValue = SortedRangeArray(ArrayLoop, 2) ' Save the value as the max value
ElseIf SortedRangeArray(ArrayLoop, 2) < Column_A_NameMinValue Then ' Else if value found < saved min value then ...
Column_A_NameMinValue = SortedRangeArray(ArrayLoop, 2) ' Save the value as the min value
End If
Else ' Else if unexpected New name found then ...
AverageArray(ResultsCount, 1) = Column_A_Name ' Save the previous name into AverageArray
Average = (Column_A_NameMaxValue + Column_A_NameMinValue) / 2 ' Save the average of the high and low values into Average
AverageArray(ResultsCount, 2) = Average ' Save Average into AverageArray
'
NewCheck = "YES" ' Set the NewCheck flag to indicate we are expecting new name
ArrayLoop = ArrayLoop - 1 ' Decrement ArrayLoop counter so we can grab the new name
End If
End If
NextCheck:
Next ' Loop back
'
AverageArray(ResultsCount, 1) = Column_A_Name ' Save the current name into AverageArray
AverageArray(ResultsCount, 2) = (Column_A_NameMaxValue + Column_A_NameMinValue) / 2 ' Save the average into AverageArray
'
Range("A1:B" & Lastrow) = AverageArray ' Display Results back to the data range
End Sub