Процедура находит диапазон данных, проходит через его значения, добавляет уникальные значения в словарь с суммой для определенной строки, а затем загружает все эти значения вместе с суммами на строку.
Option Explicit
Sub CountStuff()
Dim wb As Workbook, ws As Worksheet
Dim lColumn As Long, lRow As Long, lColTotal As Long
Dim i As Long, j As Long
Dim rngData As Range, iCell As Range
Dim dictVal As Object
Dim vArr(), vArrSub(), vArrEmpt()
'Your workbook
Set wb = ThisWorkbook
'Set wb = Workbooks("Workbook1")
'Your worksheet
Set ws = ActiveSheet
'Set ws = wb.Worksheets("Sheet1")
'Number of the first data range column
lColumn = ws.Rows(1).Find("1", , xlValues, xlWhole).Column
'Number of the last row of data range
lRow = ws.Cells(ws.Rows.Count, lColumn).End(xlUp).Row
'Total number of data range columns
lColTotal = ws.Cells(1, lColumn).End(xlToRight).Column - lColumn + 1
'Data range itself
Set rngData = ws.Cells(1, lColumn).Resize(lRow, lColTotal)
'Creating a dictionary
Set dictVal = CreateObject("Scripting.Dictionary")
'Data values -> array
vArr = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, _
rngData.Columns.Count).Value
'Empty array
ReDim vArrEmpt(1 To UBound(vArr, 1))
'Loop through all values
For i = LBound(vArr, 1) To UBound(vArr, 1)
For j = LBound(vArr, 2) To UBound(vArr, 2)
'Value is not numeric and is not in dictionary
If Not IsNumeric(vArr(i, j)) And _
Not dictVal.Exists(vArr(i, j)) Then
'Add value to dictionary
dictVal.Add vArr(i, j), vArrEmpt
vArrSub = dictVal(vArr(i, j))
vArrSub(i) = vArr(i, j - 1)
dictVal(vArr(i, j)) = vArrSub
'Value is not numeric but already exists
ElseIf dictVal.Exists(vArr(i, j)) Then
vArrSub = dictVal(vArr(i, j))
vArrSub(i) = vArrSub(i) + vArr(i, j - 1)
dictVal(vArr(i, j)) = vArrSub
End If
Next j
Next i
'Define new range for results
Set rngData = ws.Cells(1, lColumn + lColTotal - 1). _
Offset(0, 2).Resize(1, dictVal.Count)
'Load results
rngData.Value = dictVal.Keys
For Each iCell In rngData.Cells
iCell.Offset(1, 0).Resize(lRow - 1).Value _
= Application.Transpose(dictVal(iCell.Value))
Next
End Sub