Sub tt()
Dim a, i&, t$
Dim oDict As Object, kk

a = [a1].CurrentRegion.Value

Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
    For i = 2 To UBound(a)
        t = a(i, 1) & "|" & a(i, 3)
        oDict.Item(t) = oDict.Item(t) + a(i, 4)
    Next

ReDim a(1 To oDict.Count + 1, 1 To 4)
a(1, 1) = "Токен"
a(1, 2) = "неужный Тип трафика"
a(1, 3) = "Домен"
a(1, 4) = "Показы"

  i = 1
    For Each kk In oDict.keys
        i = i + 1
        a(i, 1) = Split(kk, "|")(0)
        a(i, 3) = Split(kk, "|")(1)
        a(i, 4) = oDict.Item(kk)
    Next
        
    With Workbooks.Add(1).Sheets(1)
        .Cells(1).Resize(UBound(a), 4) = a
        .Cells.EntireColumn.AutoFit
    End With
    

End Sub

Option Explicit

Sub ttt()
Dim a, i&, t$
Dim oDict As Object, oDict2 As Object, kk, el

a = [a1].CurrentRegion.Value

Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
Set oDict2 = CreateObject("Scripting.Dictionary"): oDict2.comparemode = 1

On Error Resume Next
    For i = 2 To UBound(a)
        t = a(i, 1) & "|" & a(i, 3)
        oDict.Item(t) = oDict.Item(t) + a(i, 4)
        If Not oDict2.exists(t) Then oDict2.Add t, New Collection
        oDict2.Item(t).Add a(i, 2), "" & a(i, 2)
    Next
On Error GoTo 0

ReDim a(1 To oDict.Count + 1, 1 To 4)
a(1, 1) = "Токен"
a(1, 2) = "Тип трафика"
a(1, 3) = "Домен"
a(1, 4) = "Показы"

  i = 1
    For Each kk In oDict.keys
        i = i + 1
        a(i, 1) = Split(kk, "|")(0)
        t = ""
        For Each el In oDict2.Item(kk)
        t = t & ", " & el
        Next
        a(i, 2) = Mid(t, 3)
        a(i, 3) = Split(kk, "|")(1)
        a(i, 4) = oDict.Item(kk)
    Next
        
    With Workbooks.Add(1).Sheets(1)
        .Cells(1).Resize(UBound(a), 4) = a
        .Cells.EntireColumn.AutoFit
    End With
    
End Sub

Option Explicit

Sub ttt()
Dim a, i&, t$
Dim oDict As Object, oDict2 As Object, kk, el

a = [a1].CurrentRegion.Value ' берём в массив данные

'создаём два словаря, у ключей не будем учитывать строчные или прописные (это может и лишнее)
Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
Set oDict2 = CreateObject("Scripting.Dictionary"): oDict2.comparemode = 1

On Error Resume Next 'отключение ошибок при повторах в наполнения коллекции
    For i = 2 To UBound(a) 'цикл по массиву
        t = a(i, 1) & "|" & a(i, 3) 'временная переменная - это будет ключ словаря. Создаю чтобы далее по коду сэкономить символы, да и быстрее - не лезем лишний раз в массив
        oDict.Item(t) = oDict.Item(t) + a(i, 4) 'в первый словарь каждому ключу собираем суммы из массива столбец 4
        If Not oDict2.exists(t) Then oDict2.Add t, New Collection 'если во втором словаре ещё нет ключа - добавляем с пустой коллекцией
        oDict2.Item(t).Add a(i, 2), "" & a(i, 2) ' в коллекцию ключа добавляем значение второго столбца массива (Тип трафика) - будут только уникальные, т.к. коллекция с ключём (строкового типа)
    Next
On Error GoTo 0 'включение ошибок

ReDim a(1 To oDict.Count + 1, 1 To 4) 'создаём массив для результатов работы теперь уже известного размера

i = 1
'пишем шапки, хотя это можно сделать и в конце уже на листе одним действием, но так понятнее
a(i, 1) = "Токен"
a(i, 2) = "Тип трафика"
a(i, 3) = "Домен"
a(i, 4) = "Показы"

'перебор ключей первого словаря (в обоих ключи одинаковы)
    For Each kk In oDict.keys
        i = i + 1
        a(i, 1) = Split(kk, "|")(0) 'пишем токен (из ключа, до разделителя)
        t = ""
        For Each el In oDict2.Item(kk) 'перебором коллекции ключа собираем строку "Тип трафика"
        t = t & ", " & el
        Next
        a(i, 2) = Mid(t, 3) 'пишем собранную строку без первых ", "
        a(i, 3) = Split(kk, "|")(1) 'пишем домен (из ключа, после разделителя)
        a(i, 4) = oDict.Item(kk) 'пишем собранную сумму
    Next
        
    With Workbooks.Add(1).Sheets(1) 'создание новой книги с одним листом
        .Cells(1).Resize(UBound(a), 4) = a ' выгрузка заполненного массива
        .Cells.EntireColumn.AutoFit 'задаём автоширину столбцов
    End With
    
End Sub