Option Base 1           ' Arrays start from 1: Dim arr(2,2) == Dim arr(1 To 2, 1 To 2)
Option Explicit         ' Require declaration of all variables
Option Private Module   ' Visibility of macro in MacroWindow (Alt+F8)
'====================================================================================================
'====================================================================================================
' Function return count of the changed cells or "-1" if Error
Function AggregateByCriteria(rngInsert As Range, TypeGet$, rng1ColCrit As Range, Optional rng1ColGet As Range, Optional CaseIgnore As Boolean, Optional UniqJoin As Boolean) As Long ' TypeGet: "count", "sum", "max", "join"
Dim dIns As New Dictionary, dFind As New Dictionary ' or «Dim dIns As Object (and others…): Set dIns=CreateObject("Scripting.Dictionary")» — if lib "Microsoft Scripting Runtime" NOT in Tools—>References
Dim fCount As Boolean, fSum As Boolean, fMax As Boolean, fJoin As Boolean
Dim x, aCrit, aGet, aAreas(), aColl(), aOne(1, 1)
Dim t!, a&, r&, c&, p&, nI&, nF&, AC&, f As Boolean
Const sepJoin$ = "|•$%@#•|"

t = Timer
AggregateByCriteria = -1

    Select Case LCase$(TypeGet)
        Case "count":   fCount = True
        Case "sum":     fSum = True:    f = rng1ColGet Is Nothing
        Case "max":     fMax = True:    f = rng1ColGet Is Nothing
        Case "join":    fJoin = True:   f = rng1ColGet Is Nothing
        Case Else: MsgBox "TypeGet «" & TypeGet & "» doesn't Exists!" & vbLf & "Only «Count», «Sum», «Max» or «Join»!", vbCritical, Format$(Timer - t, "0.00 sec"): Exit Function
    End Select

If f Then MsgBox "Missing of «rng1ColGet» (RangeOneCol with Values to Aggregate)!", vbCritical, Format$(Timer - t, "0.00 sec"): Exit Function


ReDim aAreas(rngInsert.Areas.Count)
For a = 1 To UBound(aAreas)             ' 1. Collect keys, need to search -------------------------
    aCrit = rngInsert.Areas(a).Value                                                                ' Area.Value to Array2D
    If Not IsArray(aCrit) Then aOne(1, 1) = aCrit: aCrit = aOne                                     ' If one cell, transform with temp Array2D

    For c = 1 To UBound(aCrit, 2)
        For r = 1 To UBound(aCrit, 1)
            If IsError(aCrit(r, c)) Then GoTo nx1                                                       ' Skip error
            If Len(aCrit(r, c)) = 0 Then GoTo nx1                                                       ' Skip empty
            If CaseIgnore Then aCrit(r, c) = LCase$(aCrit(r, c)) Else aCrit(r, c) = CStr(aCrit(r, c))   ' Key to text
            x = dIns(aCrit(r, c))                                                                       ' Fill dic with only Keys
nx1:    Next r
    Next c

    aAreas(a) = aCrit                                                                               ' Save Area.Value to Array1D of Arrays2D
Next a

nI = dIns.Count: If nI = 0 Then MsgBox "There is NO any Currient Keys to Search in the Insert Range!", vbCritical, Format$(Timer - t, "0.00 sec"): Exit Function


ReDim aColl(dIns.Count)                     ' Array1D for collecting
aCrit = rng1ColCrit.Value2                  ' Array2D of Values to Search [Criterias]
If Not fCount Then aGet = rng1ColGet.Value2 ' Array2D of Values to Collect

For r = 1 To UBound(aCrit, 1)           ' 2. Collect Values by Keys -------------------------------
    If IsError(aCrit(r, 1)) Then GoTo nx2
    If Not fCount Then If IsError(aGet(r, 1)) Then GoTo nx2

    If Len(aCrit(r, 1)) = 0 Then GoTo nx2
    If Not fCount Then If Len(aGet(r, 1)) = 0 Then GoTo nx2

    If CaseIgnore Then aCrit(r, c) = LCase$(aCrit(r, c)) Else aCrit(r, c) = CStr(aCrit(r, c))
    If Not dIns.Exists(aCrit(r, c)) Then GoTo nx2                                                   ' Check Current Criteria in dic of Searching Keys

    If dFind.Exists(aCrit(r, c)) Then
        a = dFind(aCrit(r, c))

        If fCount Then
            aColl(a) = aColl(a) + 1
        ElseIf fSum Then
            If IsNumeric(aGet(r, 1)) Then aGet(r, 1) = --aGet(r, 1) Else GoTo nx2
            If Len(aColl(a)) = 0 Then aColl(a) = aGet(r, 1)
            aColl(a) = aColl(a) + aGet(r, 1)
        ElseIf fMax Then
            If IsNumeric(aGet(r, 1)) Then aGet(r, 1) = --aGet(r, 1) Else GoTo nx2
            If Len(aColl(a)) = 0 Then aColl(a) = aGet(r, 1): GoTo nx2
            If aColl(a) < aGet(r, 1) Then aColl(a) = aGet(r, 1)
        Else
            If InStr(aGet(r, 1), sepJoin) Then GoTo erSep
            aColl(a) = aColl(a) & sepJoin & aGet(r, 1)
        End If
    Else
        nF = nF + 1: dFind.Add aCrit(r, c), nF

        If fCount Then
            aColl(nF) = 1
        ElseIf fSum Or fMax Then
            If IsNumeric(aGet(r, 1)) Then aColl(nF) = --aGet(r, 1)
        Else
            If InStr(aGet(r, 1), sepJoin) Then GoTo erSep
            aColl(nF) = aGet(r, 1)
        End If
    End If
nx2:
Next r

dIns.RemoveAll
nF = dFind.Count: AggregateByCriteria = nF
If nF = 0 Then MsgBox "Can't Find any Keys of Insert Range in «rng1ColCrit» (RangeOneCol with Criterias)!", vbCritical, "AggregateByCriteria": Exit Function

Application.ScreenUpdating = False
AC = Application.Calculation: Application.Calculation = xlCalculationManual

For a = 1 To UBound(aAreas)             ' 3. Fill rngIns. Change Keys by Aggregate Values ---------
    aCrit = aAreas(a)

    For c = 1 To UBound(aCrit, 2)
        For r = 1 To UBound(aCrit, 1)
            If IsError(aCrit(r, c)) Then GoTo nx3
            If Len(aCrit(r, c)) = 0 Then GoTo nx3
            If Not dFind.Exists(aCrit(r, c)) Then GoTo nx3
            If Not fJoin Then aCrit(r, c) = dFind(aCrit(r, c)): GoTo nx3
            If Not UniqJoin Then aCrit(r, c) = dFind(aCrit(r, c)): GoTo nx3

            For Each x In Split(dFind(aCrit(r, c)), sepJoin)
                x = dIns(x)
            Next x

            aCrit(r, c) = Join(dIns.Keys, sepJoin)
            dIns.RemoveAll
nx3:    Next r
    Next c

    rngInsert.Areas(a).Value = aCrit
Next a

Application.Calculation = AC
Application.ScreenUpdating = True
Exit Function

erSep: MsgBox "Values to Join can't exists the Separator «" & sepJoin & "»!", vbCritical, "AggregateByCriteria"
End Function