How do I limit an array to a single column in VBA?

This problem can be solved quite easily by using the GROUPBY function.
Example formula (addresses as in the screenshot):
=GROUPBY($C$1:$C$13,$A$1:$B$13,AVERAGE,3,0)

This formula can also be entered using VBA, e.g. with the following code (result in cell H1):

Sub GroupAvg()
    Dim dest As Range
    Set dest = Range("H1")
    dest.Formula2 = "=GROUPBY($C$1:$C$13,$A$1:$B$13,AVERAGE,3,0)"
End Sub  

Column headers are optional. The data is sorted in ascending order by the Categories column. You can change the order to descending, but you cannot opt out of sorting.

A slightly different (reusable) approach which will summarize multiple columns and return the results in an array:

Sub Tester()
    
    Dim summ
    'get column averages based on key in column index 3
    summ = Summary([B3:G18], 3, Array(1, 2, 4, 5, 6))
    
    [I3].Resize(UBound(summ, 1), UBound(summ, 2)).Value = summ

End Sub

'For data in range `rngIn`, average numeric values in columns within `arrValueCols`,
'  grouping by the value in column `keyCol`, and return the result as a 2D 1-based array
Function Summary(rngIn As Range, keyCol As Long, arrValueCols)

    Dim data, dict As Object, k, r As Long, arrOut, indx As Long, c As Long, tmp, v
    Dim numKeys
    
    numKeys = UBound(Application.Unique(rngIn.Columns(keyCol))) '# of unique keys
    data = rngIn.Value 'get data as array
    ReDim arrOut(1 To numKeys, 1 To UBound(arrValueCols) + 2) 'size return array
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For r = 1 To UBound(data, 1)
        k = data(r, keyCol)
        If Not dict.exists(k) Then 'new key?
            indx = indx + 1
            dict.Add k, indx
            arrOut(indx, 1) = k 'populate the key in the return array
        End If
        For c = 0 To UBound(arrValueCols) 'loop over the columns to be summarized
            v = data(r, arrValueCols(c))
            If Len(v) > 0 And IsNumeric(v) Then    'any value to process?
                tmp = arrOut(dict(k), c + 2)  'extract the array
                If IsEmpty(tmp) Then tmp = Array(0, 0) 'no array yet ? Create it...
                tmp(0) = tmp(0) + v
                tmp(1) = tmp(1) + 1
                arrOut(dict(k), c + 2) = tmp  'return the array
            End If
        Next c
    Next r
    
    For Each k In dict 'calculate the averages
        For c = 0 To UBound(arrValueCols)
            tmp = arrOut(dict(k), c + 2)
            If Not IsEmpty(tmp) Then arrOut(dict(k), c + 2) = tmp(0) / tmp(1)
        Next c
    Next k
    Summary = arrOut
End Function

Example:

EDIT: a version which adds the ability to specify multiple "key" columns:

Sub Tester2()
    
    Dim summ
    
    summ = Summary([B2].CurrentRegion, Array(3, 5), Array(1, 2, 4, 6, 7))
    
    [K2].Resize(UBound(summ, 1), UBound(summ, 2)).Value = summ

End Sub

'For data in range `rngIn`, average numeric values in columns within `arrValueCols`,
'  grouping by the value(s) in columns within `arrKeyCols`,
'  and return the result as a 2D 1-based array.
'  If `hasHeaders` is true, return the headers from the input range as the first row
Function Summary(rngIn As Range, arrKeyCols, arrValueCols, Optional hasHeaders As Boolean = True)
    Const SEP_STR As String = "<|>"
    Dim data, dict As Object, k, r As Long, nr As Long, arrOut, indx As Long, c As Long, tmp, v
    Dim numKeys, numKeyCols As Long, numValueCols As Long, arrKeys, sep, el, arr, colPos As Long
    Dim rStart As Long
    
    numKeyCols = ArraySize(arrKeyCols)
    numValueCols = ArraySize(arrValueCols)
    
    rStart = IIf(hasHeaders, 2, 1)
    data = rngIn.Value      'get data as array
    nr = UBound(data, 1)    '# of rows
    Set dict = CreateObject("Scripting.Dictionary")
    ReDim arrKeys(1 To nr)  'for storing each row's key
    
    'start by building the row keys and collecting the unique key values
    '## decide here how you want to handle empty key values ##
    indx = IIf(hasHeaders, 1, 0)  'adjust for headers
    For r = rStart To nr
        k = ""
        sep = ""
        For Each el In arrKeyCols 'build the key for this row
            k = k & sep & data(r, el)
            sep = SEP_STR
        Next el
        arrKeys(r) = k             'store the row key
        If Not dict.exists(k) Then '...add key to dict if new key
            indx = indx + 1
            dict.Add k, indx       'relate key to row of output array
        End If
    Next r
    
    ReDim arrOut(1 To dict.Count + IIf(hasHeaders, 1, 0), _
                 1 To numKeyCols + numValueCols) 'size return array
    If hasHeaders Then 'need to fill the headers in the output?
        c = 1
        For Each arr In Array(arrKeyCols, arrValueCols)
            For Each el In arr
                arrOut(1, c) = data(1, el)
                c = c + 1
            Next el
        Next arr
    End If
    
    'fill key columns in output array
    For Each k In dict
        arr = Split(k, SEP_STR)
        c = 1
        For Each el In arr
            arrOut(dict(k), c) = el
            c = c + 1
        Next el
    Next k
    
    'first collect the data in the output array...
    For r = rStart To nr
        k = arrKeys(r)   'get the stored key
        For c = 0 To UBound(arrValueCols) 'loop over the columns to be summarized
            colPos = c + numKeyCols + 1   'column in the output array
            v = data(r, arrValueCols(c))
            If Len(v) > 0 And IsNumeric(v) Then        'any value to process?
                tmp = arrOut(dict(k), colPos)          'extract the array
                If IsEmpty(tmp) Then tmp = Array(0, 0) 'no array yet ? Create it...
                tmp(0) = tmp(0) + v           'add value to total
                tmp(1) = tmp(1) + 1           'increment the count
                arrOut(dict(k), colPos) = tmp 'return the array
            End If
        Next c
    Next r
    
    '...then calculate the averages
    For Each k In dict
        For c = 0 To UBound(arrValueCols)
            colPos = c + numKeyCols + 1
            tmp = arrOut(dict(k), colPos)
            If Not IsEmpty(tmp) Then arrOut(dict(k), colPos) = tmp(0) / tmp(1)
        Next c
    Next k
    Summary = arrOut
End Function

Function ArraySize(arr) As Long
    ArraySize = 1 + (UBound(arr) - LBound(arr))
End Function

'Condense' Code!?

• By splitting your code into helper procedures, you could make your code more readable and shorter.

Main

Sub CalculateUniqueAverages()

    Const FIRST_ROW As Long = 12

    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    ReadData dict, ws, FIRST_ROW, LastRow, 4, 2 ' 1st Values
    WriteCategories dict, ws, FIRST_ROW, 5 ' Unique Categories
    WriteAverages dict, ws, FIRST_ROW, 6 ' 1st Averages
    
    ReadData dict, ws, FIRST_ROW, LastRow, 4, 3 ' 2nd Values
    WriteAverages dict, ws, FIRST_ROW, 7 ' 2nd Averages
    
End Sub

• Note that e.g. ReadData dict, ws, FIRST_ROW, LastRow, 4, 2 is short for

  ReadData dict:=dict, ws:=ws, FirstRow:=FIRST_ROW, LastRow:=LastRow, _
      CategoryColumn:=4, ValueColumn:=2
  

  As soon as you type ReadData and press space, the IntelliSense will show the arguments.

Help

Sub ReadData( _
        ByRef dict As Object, _
        ByVal ws As Worksheet, _
        ByVal FirstRow As Long, _
        ByVal LastRow As Long, _
        ByVal CategoryColumn As Long, _
        ByVal ValueColumn As Long)
    
    dict.RemoveAll
    
    Dim ccell As Range, vcell As Range, Key As Variant, i As Long
    
    For i = FirstRow To LastRow
        Set ccell = ws.Cells(i, CategoryColumn)
        If ccell.Value <> "" Then
            Key = ccell.Value
            Set vcell = ws.Cells(i, ValueColumn)
            If Not dict.Exists(Key) Then
                dict(Key) = Array(vcell.Value, 1)
            Else
                dict(Key) = Array(dict(Key)(0) + vcell.Value, dict(Key)(1) + 1)
            End If
        End If
    Next i

End Sub

Sub WriteCategories( _
        ByVal dict As Object, _
        ByVal ws As Worksheet, _
        ByVal FirstRow As Long, _
        ByVal CategoryColumn As Long)
    
    Dim ResultRow As Long: ResultRow = FirstRow
    
    Dim Key As Variant
    
    For Each Key In dict.Keys
        ws.Cells(ResultRow, CategoryColumn).Value = Key
        ResultRow = ResultRow + 1
    Next Key

End Sub

Sub WriteAverages( _
        ByVal dict As Object, _
        ByVal ws As Worksheet, _
        ByVal FirstRow As Long, _
        ByVal AverageColumn As Long)
    
    Dim ResultRow As Long: ResultRow = FirstRow
    
    Dim Key As Variant
    
    For Each Key In dict.Keys
        ws.Cells(ResultRow, AverageColumn).Value = dict(Key)(0) / dict(Key)(1)
        ResultRow = ResultRow + 1
    Next Key

End Sub