VBA find a range of same values in a column and calculate average

Question

I want to find a range of same values in column A , and then calculate it average , can anyone help me ? below the code :

https://i.sstatic.net/bU1hW.png

Sub test()
    Dim sht As Worksheet
    Dim LastRow As Long
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

For i = 1 To LastRow
Columns("A:A").Select
    Set cell = sELECTION.Find(What:="i", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

If cell Is Nothing Then
    'do it something

Else
    'do it another thing
End If

End Sub

Thanks !

Answer 1

Solution 1

Try this

Sub test()
    Dim sht As Worksheet
    Dim inputLR As Long, outputLR As Long
    Dim cel As Range, aRng As Range, bRng As Range

    Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet

    With sht
        inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row    'last row in column A
        outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row   'last row in column D
        Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
        Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B

        For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4))   'loop through each cell in Column D
            cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
        Next cel
    End With
End Sub

See image for reference.

Solution 2

Another easier approach will be to use formula. Enter the following formula in Cell E2

=AVERAGEIF($A$2:$A$11,D2,$B$2:$B$11)

Drag/Copy down as required. Change range as per your data.

For details on AVERAGEIF see this.

---

EDIT : 1

Sub test()
    Dim sht As Worksheet
    Dim inputLR As Long, outputLR As Long
    Dim cel As Range, aRng As Range, bRng As Range
    Dim dict As Object, c As Variant, i As Long

    Set dict = CreateObject("Scripting.Dictionary")
    Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet

    With sht
        inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row    'last row in column A
        Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
        Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B

        c = aRng
        For i = 1 To UBound(c, 1)
            dict(c(i, 1)) = 1
        Next i
        .Range("D2").Resize(dict.Count) = Application.Transpose(dict.keys)  'display uniques from column A
        outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row   'last row in column D

        For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4))   'loop through each cell in Column D
            cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
        Next cel
    End With
End Sub

---

EDIT : 2 To get Min, instead of

For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4))   'loop through each cell in Column D
    cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel

use

For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4))   'loop through each cell in Column D
    cel.Offset(0, 1).FormulaArray = "=MIN(IF(" & aRng.Address & "=" & cel.Value & "," & bRng.Address & "))"
Next cel
.Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value = .Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value

Answer 2

Please try this code:

Sub test()

    Dim sht As Worksheet
    Dim LastRow As Long
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

    For i = 1 To LastRow        
        If Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i)) > 1 Then
            'if found more than one value
            'do it another thing
            sht.Range("B" & i) = Application.WorksheetFunction.SumIf(sht.Range("A1:A" & LastRow), _
                            sht.Range("A" & i)) / Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i))
        Else
           'do it another thing
        End If
    Next i

End Sub

Hope this help.

Answer 3

To use the .Find Function

1. Find the values in column A excluding duplicates
2. Use the unique values on the Find Function
3. When the value is found, sum the value in column B and on a counter

4. Divide the sum value by the counter to obtain the average value

   Dim ws As Worksheet
   Dim rng As Range, rngloop As Range, cellFound As Range, c As Range
   
   Set ws = ThisWorkbook.Sheets(1)
   lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastrow, 1))
   
   For i = 2 To lastrow
   
       Set c = ws.Cells(i, 1)
       Set rngloop = ws.Range(ws.Cells(2, 1), ws.Cells(i, 1))
   
       x = Application.WorksheetFunction.CountIf(rngloop, c)
   
       If x = 1 Then
       'Debug.Print c 'Values in column A without duplicates
           'Work with the values found
           With rng
           Set cellFound = .Find(what:=c, LookIn:=xlValues, MatchCase:=False)
               If Not cellFound Is Nothing Then
                   FirstAddress = cellFound.Address
                   Do
                       SumValues = ws.Cells(cellFound.Row, 2) + SumValues
                       k = k + 1
                       Set cellFound = .FindNext(cellFound)
                   Loop While Not cellFound Is Nothing And cellFound.Address <> FirstAddress
                   AverageValues = SumValues / k
                   Debug.Print "Value: " & c & " Average: " & AverageValues
                End If
           End With
       End If
       k = 0
       SumValues = 0
   Next i
   

Note that the use of .Find is slower than CreateObject("Scripting.Dictionary"), so for large Spreadsheets the code of @Mrig is optimized

Answer 4

This is using a variant array method. Try this.

Sub test()
    Dim sht As Worksheet
    Dim LastRow As Long
    Dim vDB, vR(), rngDB, vResult()
    Dim r As Integer, n As Long, j As Long, i As Integer

    Set sht = ThisWorkbook.Worksheets("Sheet1")
    With sht
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        rngDB = .Range("a1", "b" & LastRow)
        vDB = .Range("d2", .Range("d" & Rows.Count).End(xlUp))

        r = UBound(vDB, 1)
        ReDim vResult(1 To r)
        For i = 1 To r
            n = 0
            For j = 1 To LastRow
                If vDB(i, 1) = rngDB(j, 1) Then
                    n = n + 1
                    ReDim Preserve vR(1 To n)
                    vR(n) = rngDB(j, 2)
                End If
            Next j
            vResult(i) = WorksheetFunction.Average(vR)
        Next i
        .Range("e2").Resize(r) = WorksheetFunction.Transpose(vResult)
    End With
End Sub

Answer 5

Use WorksheetFunction.AverageIf function, see code below :

Sub test()

Dim sht As Worksheet
Dim LastRow As Long
Dim Rng As Range
Dim Avg1 As Double, Avg2 As Double

Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set Rng = .Range("A1:A" & LastRow)
    ' average of values in column B of all cells in column A = 1
    Avg1 = WorksheetFunction.AverageIf(Rng, "1", .Range("B1:B" & LastRow))

    ' average of values in column B of all cells in column A = 2
    Avg2 = WorksheetFunction.AverageIf(Rng, "2", .Range("B1:B" & LastRow))
End With

End Sub