Объединение одинаковых данных и подсчет их(в огромных таблицах)

[Nicotinni]

Как сделать так, чтобы одинаковые данные он объединял, и показывал сколько этих объединений было сделано. например, библиотечный список книг, в нем много авторов и у каждого автора свои книги. сортировку по авторам сделали, сортировку по названиям книг сделали, получилось очень много одинаковых книг. как сделать так, чтобы он обединял эти книги и показывал, сколько их было обединено. вручную делать невозможно. слишком много книг. таблица самая маленькая-4тыс наименований. а в среднем около 120 тыс.
Вот это есть:
!Авторы ! Заголовок !
!автор1 ! заголовок(АА) !
!автор1 ! заголовок(АА) !
!автор1 ! заголовок(ББ) !
!автор1 ! заголовок(ББ) !
!автор2 ! заголовок(жж) !
!автор2 ! заголовок(ээ) !
!автор3 ! заголовок(хх) !
!автор3 ! заголовок(хх) !

Нужно чтобы выглядела вот так:

!Авторы ! Заголовок !количество\шт!
!автор1 ! заголовок(АА) ! 2 !
! ! ! !
!автор1 ! заголовок(ББ) ! 2 !
! ! ! !
!автор2 ! заголовок(жж) ! 1 !
!автор2 ! заголовок(ээ) ! 1 !
!автор3 ! заголовок(хх) ! 2 !
! ! ! !

[Hugo121]

Таблицы в 120 тыс. в Экселе?
Сделать несложно, на массиве и Dictionary будет даже очень быстро.

[nilem]

Массивы и немного коллекции...

[Hugo121]

Хотел сказать - вот заглянет Николай и сделает. Но воздержался...
Если эти 120 тыс. в текстовом файле лежат (и в старый Эксель не лезут), можно прямо его в массив тянуть, а при выгрузке смотреть - помещается результат на лист или нет. Если нет - выгружать на два.
А я тут после работы в лес по грибы заехал - белых как никогда.... Так что для макроса времени не было
Но обдумал - я бы наверное в словарь грузил и параллельно в другой массив, а номер записи брал из словаря, чтоб суммы подбивать существующим.

P.S. Вот кстати и сделал для параллельной темы - результат с кодом Николая одинаков, можно даже этот код из того файла запускать - только что выгружает правее на одну позицию. Вот на время бы сравнить - сравнил. Я выиграл - 5-10%

Option Explicit

Sub UniqCount()
    Dim i As Long, ind As Long
    Dim d As Scripting.Dictionary
    Dim arr1, arr2, rng As Range
    
    Set d = New Dictionary

    Set rng = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row)
    arr1 = rng.Value
    ReDim arr2(1 To UBound(arr1), 1 To 3)

    For i = 1 To UBound(arr1, 1)
        If d.Exists(UCase(CStr(arr1(i, 1) & arr1(i, 2)))) Then
            arr2(d.Item(UCase(CStr(arr1(i, 1) & arr1(i, 2)))), 3) = arr2(d.Item(UCase(CStr(arr1(i, 1) & arr1(i, 2)))), 3) + 1
        Else
            ind = ind + 1
            d.Add UCase(CStr(arr1(i, 1) & arr1(i, 2))), ind
            arr2(ind, 1) = arr1(i, 1)
            arr2(ind, 2) = arr1(i, 2)
            arr2(ind, 3) = arr2(ind, 3) + 1

        End If
    Next i

    rng.Offset(, 4) = arr2

End Sub

[SAS888]

Ну, если речь пошла о времени выполнения, то предложу и свой вариант. Он мало отличается от варианта nilem, но, чуть быстрее. Посмотрите вложение в котором более 60 000 строк и в котором объединены все 3 варианта с измерением времени выполнения. Для корректной оценки, попробуйте каждый вариант запустить по несколько раз.

P.S. Необходимо заметить, что в варианте Hugo121 отсутствует сортировка. В принципе, для решения задачи таким способом она и не нужна, но если это нужно автору вопроса, то время выполнения процедуры увеличится.

[nilem]

SAS888, да, Ваш код быстрее (и выглядит проще). Т.е. заполнять новый массив быстрее, чем перезаписывать существующий? - по сравнению со своим вариантом основное отличие увидел только в этом (доп. функции вроде бы не должны тормозить).
Чтобы уж не экспериментировать, расскажите в чем преимущества Вашего подхода.

[Hugo121]

Хорошо, погоняемся. Я свой код чуть подкрутил, добавил пару переменных:

Sub UniqCount()
    iTimer! = Timer
    Dim i As Long, ind As Long
    Dim d As Scripting.Dictionary
    Dim arr1, arr2, rng As Range, x As Long, temp As String
    Set d = New Dictionary
    Set rng = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row)
    arr1 = rng.Value
    ReDim arr2(1 To UBound(arr1), 1 To 3)
    x = UBound(arr1, 1)
    For i = 1 To x 'UBound(arr1, 1)
    temp = UCase(CStr(arr1(i, 1) & arr1(i, 2)))
        If d.Exists(temp) Then
            arr2(d.Item(temp), 3) = arr2(d.Item(temp), 3) + 1
        Else
            ind = ind + 1
            d.Add temp, ind
            arr2(ind, 1) = arr1(i, 1)
            arr2(ind, 2) = arr1(i, 2)
            arr2(ind, 3) = 1 'arr2(ind, 3) + 1
        End If
    Next i
    rng.Offset(, 7) = arr2
    MsgBox "Время выполнения макроса составило " & Timer - iTimer! & " сек.", vbExclamation, ""
End Sub

Результат = мой 0,40, ваши оба по 0,65 в среднем...

[doober]

Сообщение от Hugo121

Хорошо, погоняемся.

Моя лошадка пробегает дистанцию за 1 секунду,но привозит совершенно другой результат

[Hugo121]

Ну так - яж ещё дополнительно UCase подключил
А в коллекциях похоже по регистру данные не отличить?
В моём варианте можно легко переключение организовать, по чекбоксу например.
И кстати без UCase() моя лошадка за 0,37 пробегает

[doober]

Hugo121 На время выполнения вашего варианта не влияет предварительная сортировка