Average of duplicates, delete remaining

[DreyFox]

Hello,
I have the following data:

I would like to find the duplicates, get the highest and the lowest values in column B, then consolidate into one. For example, take T1:
T1, highest = 5.18, T1 lowest = 1

The vba algorithm would take the avg, insert a row below the last T1 entry with the cell A being T1 and cell B being the average. The remaining results before the averages T1's are deleted (The rows are deleted).

Its kind of complex and I'm not sure how to really do this using VBA.

 

[NdNoviceHlp]

Hi DreyFox. You can trial this code. Please save a copy of your workbook before trialing the code. HTH. Dave

Sub test()
Dim Cnt As Integer, Cnt1 As Integer, Cnter As Integer, Total As Double, Rng As Range
Dim Avg As Double, Lastrow As Integer, NameArr() As Variant, AvgArr() As Variant
With Sheets("Sheet1")
    Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set Rng = .Range(.Cells(1, "A"), .Cells(Lastrow, "B"))
'sort unique
For Cnt = 1 To Lastrow
For Cnt1 = 1 To (Cnt - 1)
If .Range("A" & Cnt1).Value = .Range("A" & Cnt).Value Then ' more than one entry
GoTo Bart
End If
Next Cnt1
Cnter = Cnter + 1
ReDim Preserve NameArr(Cnter)
NameArr(Cnter - 1) = .Range("A" & Cnt).Value
Bart:
Next Cnt
'loop unique & generate averages
For Cnt = LBound(NameArr) To UBound(NameArr) - 1
Total = 0
Cnter = 0
ReDim Preserve AvgArr(Cnt + 1)
For cnt2 = 1 To Lastrow
If .Range("A" & cnt2).Value = NameArr(Cnt) Then
Total = Total + .Range("B" & cnt2).Value
Cnter = Cnter + 1
End If
Next cnt2
Avg = Total / Cnter
AvgArr(Cnt) = Avg
Next Cnt
'make output
Rng.ClearContents
For Cnt = LBound(NameArr) To UBound(NameArr) - 1
.Range("A" & Cnt + 1).Value = NameArr(Cnt)
.Range("B" & Cnt + 1).Value = AvgArr(Cnt)
Next Cnt
End With
End Sub

 

[johnnyL]

Here is my version:

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

 

[kevin9999]

Here's another way.

Option Explicit
Sub Only_Averages_Left()
    Dim arr, ws, rng As Range, i As Long
    Dim d, arrOut(), arrValues(), v, tmp, n As Long
    
    Set ws = ActiveSheet
    Set rng = ws.Range("A1").CurrentRegion
    n = rng.Rows.Count
    
    arr = Range("A1", Cells(Rows.Count, "A").End(xlUp))
    arrValues = rng.Columns(2).Value
    ReDim arrOut(1 To n, 1 To 1)
    
    Set d = CreateObject("scripting.dictionary")
        For i = 1 To n
        v = arr(i, 1)
        If Not d.exists(v) Then d(v) = Array(0, 0)
        tmp = d(v)
        tmp(0) = tmp(0) + 1
        tmp(1) = tmp(1) + arrValues(i, 1)
        d(v) = tmp
    Next i
    
    For i = 1 To n
        arrOut(i, 1) = d(arr(i, 1))(1) / d(arr(i, 1))(0) '= averageif
    Next i
    
    rng.Columns(2).Value = arrOut
    ws.Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
    
End Sub

 

[kevin9999]

In my post#4, I provided you a solution that left you with the average of all values in column B that matched your criteria in column A. On rereading your question, you may have only wanted the average of the highest & lowest numbers that matched each criterion. That being the case, the following code will do that.

Option Explicit
Sub HiLoAverage()
    Dim arr, tmp() As Variant
    Dim lr As Long, i As Long, j As Long
    Dim ws As Worksheet
    Dim a As Double, b As Double
    
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    ws.Columns("A:B").Sort Key1:=ws.Range("A1"), order1:=xlAscending, Header:=xlNo
    
    arr = ws.Range("A1:B" & lr)
    ReDim tmp(1 To lr, 1 To 1) As Variant
    
    j = 1
    For i = 1 To lr - 1
        If arr(i, 1) = arr(i + 1, 1) Then
            tmp(j, 1) = arr(i, 2)
                Else
                tmp(j, 1) = arr(i, 2)
                a = (WorksheetFunction.Max(tmp) + WorksheetFunction.Min(tmp)) / 2
                b = Application.Match(arr(i, 1), Application.Index(arr, 0, 1), 0)
                ws.Range("B" & b).Resize(j).Value = a
                ReDim tmp(1 To lr, 1 To 1) As Variant
                j = 0
        End If
    j = j + 1
    Next i
    
    ws.Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
    Application.ScreenUpdating = True
End Sub