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

[Hugo121]

Обрубил массив Range([H2], Cells(d.Count + 1, 10)).Value = arr2 - стало быстрее:

nilem 0.71875 сек.
hugo 0.34375 сек.
sas888 0.5 сек.
nilem 0.703125 сек.
hugo 0.359375 сек.
sas888 0.5 сек.
nilem 0.7226563 сек.
hugo 0.3398438 сек.
sas888 0.5 сек.
nilem 0.7070313 сек.
hugo 0.359375 сек.
sas888 0.5 сек.

[SAS888]

Убрал сортировку - стало быстрее: 0,36 сек.

[Nicotinni]

Отлично, ребят!!!!! Все работает... пока что проверил только на 120 тыс... думал около 4 секунд. Но это не столь важно!
Я вам очень и очень благодарен!!!!!!!!!!!!!!!!!!!!!!!!! !! будете в питере, с меня чашка горячего шоколада)

Одно только.... он не считает книги без автора.... вот это не айс. много книг, типа библия, а там автора нет..

[Nicotinni]

похрен. сделал заполнение на все -"Неизв.". обойдутся.

[Hugo121]

Мой код считает, пока не отсортировано другими кодами . А после сортировки - считает, если в коде заменить строку на
Set rng = Range("A2:C" & Cells(Rows.Count, 2).End(xlUp).Row)

[SAS888]

Аналогично. Замените в коде строку на
Set y = Range("A2:C" & Cells(Rows.Count, 2).End(xlUp).Row)

[Nicotinni]

Ну все. Радости моей нет предела... правда чувствую себя теперь инвалидом... сам бы никогда до такого не догадался)

[Dosugx]

Привет всем! Только что недавно делал подобное, но задача немного универсальней:
Из диапазона A1:B2 или C3:XFD1048576 (указываем сами) выбирае одинаковые строки суммируя их колличество, тоесть у нас есть:
'Яблоко' 'красное' 'сладкое'
'Груша ' ' ' ' '
'Яблоко' 'красное' ' '
'Тыква ' 'большая' ' '
'Яблоко' 'красное' 'сладкое'
Получаем:
'Яблоко' 'красное' 'сладкое' '2'
'Груша ' ' ' ' ' '1'
'Яблоко' 'красное' ' ' '1'
'Тыква ' 'большая' ' ' '1'
А вот и код:

Function SumDuplicates(Table As Range)
    Dim y As Boolean
    Dim overlap As Boolean             'частичное совпадение
    Dim ii As Integer
    Dim rs As Long, rr As Long, TRC As Long 'rows source, rows result, Table.Rows.Count
    Dim cs As Integer, cr As Integer, TCC As Integer 'columns source, columns result, Table.Columns.Count
    Dim sum() As Integer
    Dim temp() As Variant              'table temp
    Dim tr() As Variant                'table result
           
    unique = 1                         'уникальные строки
    TRC = Table.Rows.Count             'возвращает количество строк в диапазоне
    TCC = Table.Columns.Count          'возвращает количество столбцов в диапазоне
    ReDim sum(TRC + 1)
    ReDim temp(1, TCC)
    ReDim tr(TRC + 1, TCC + 1)         'изменение размерности динамического массива
    
    'перебираем диапазон строк
    For rs = 1 To TRC
    'копируем всю строку source в temp
        For cs = 0 To TCC - 1
            temp(0, cs) = Table.Cells(rs, cs + 1).Value
        Next cs
        For rr = 1 To unique           'ищем одинаковые в нашем массиве
            cs = 0
            Do While (tr(rr, cs + 1) = temp(0, cs)) And (cs < TCC)
                cs = cs + 1            'сдвиг вправо по столбцу
            Loop
        
            If cs = TCC Then           'полное совпадение
                sum(rr) = sum(rr) + 1  'если строки одинаковы, добавляем к совпадению 1
                overlap = False        'сбрасываем флаг частичное совпадение
                Exit For               'прервать цикл rr (поиска совпадений)
            Else
                overlap = True         'взводим флаг частичное совпадение (нужно записать строку)
            End If
        Next rr
        If overlap Then                'запись строки в таблицу результата
            For cs = 1 To TCC
                tr(unique, cs) = temp(0, cs - 1)
            Next cs
            unique = unique + 1        'увеличиваем счетчик оригинальных строк
        End If
    Next rs
  
    Sheets.Add                         'добавить лист
    ActiveSheet.Name = "SumDuplicates"            'присвоить текущему листу имя
    For rr = 1 To unique - 1
        For cr = 1 To TCC
            Cells(rr, cr).Value = tr(rr, cr)
        Next cr
        Cells(rr, cr).Value = sum(rr) + 1
    Next rr
    SumDuplicates = TRC
    
End Function

Sub stat()
    Dim i

    i = SumDuplicates(Range("B2:DD1000"))   'здесь задаем наш диапазон

End Sub

Все бы нечего, но у Вас как посмотрел код намного меньше. Да к томуже хочется прикрутить форму что бы задавать имя листа и диапазон.

[Hugo121]

Пора Вам Dictionary осваивать.
Вот близкий по смыслу код -

Option Explicit

Sub UniqSummUniversal()
'Выделить диапазон, где в первом столбце - уникальные, в последнем - суммы
Dim a(), oDict As Object, i As Long, temp As String
Dim ind As Long
a = Selection.Value
ind = UBound(a, 2) 
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = 1
For i = 1 To UBound(a)
If IsNumeric(a(i, ind)) Then
If Not IsEmpty(a(i, ind)) Then
temp = Trim(a(i, 1))
If Not oDict.Exists(temp) Then
oDict.Add temp, CStr(a(i, ind))
Else
oDict.Item(temp) = CStr(--oDict.Item(temp) + a(i, ind))
End If
End If
End If
Next

On Error Resume Next
With Workbooks.Add.Worksheets(1)
.Range("A1").Resize(oDict.Count) = Application.Transpose(oDict.keys)
.Range("B1").Resize(oDict.Count) = Application.Transpose(oDict.items)
End With
On Error GoTo 0

End Sub

Код универсальный - под Вашу задачу нужно сделать два столбца - в один слить 'Яблоко' 'красное' 'сладкое', в другом протянуть единицы.
Ну или дописать это в код - брать как критерий 3 столбца, считать повторы, а не суммировать суммы.
Хотя код можно чуть сократить, если уж придираться...
P.S. Можно столбцы слить через "|", потом результат разбить по колонкам по этому разделителю.