Сортировка с копированием VBA

[bugx]

На всякий случай размещаю файлик результата работы, может у кого будут подобные вопросы.

[Hugo121]

Я обычно делаю так:

Sub tt()
    Dim a(), i&, ii&, t$
    a = Sheets(1).[a1].CurrentRegion.Value
    ReDim b(1 To UBound(a), 1 To 3)
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 2)
            If Not .exists(t) Then
                ii = ii + 1
                b(ii, 1) = a(i, 1): b(ii, 2) = a(i, 2): b(ii, 3) = a(i, 3)
                .Item(t) = ii
            Else
                b(.Item(t), 3) = b(.Item(t), 3) + a(i, 3)
            End If
        Next
    End With

    If ii > 0 Then Sheets(2).[e1].Resize(ii, 3) = b
End Sub

Всё прозрачно - массив, массив, словарь
Выгрузка для сравнения чуть правее.
Думаю на большом объёме будет быстрее.

P.S. В данном случае "If ii > 0 Then" лишнее, воткнул по привычке... Но в других вариантах бывает, что ничего не отобрано - тогда при выгрузке будет ошибка...