Убрать дубликаты и подсчёт суммы по каждому уникальному значению.

[Djeki]

Уважаемые знатоки Excel. Помогите пожалуста доработать макрос. Есть на листе "Массив" список фамилий в столбце А, а рядом в столбце В число, напротив каждой фамилии. Фамилии повторяются. На вашем форуме я нашёл макрос, который очень быстро делает список фамилий без повторов (уникальные значения) и выводит его на лист "Выводы". Дальше необходимо по каждой уникальной фамилии посчитать сумму по столбцу В ,с листа "Массив" и записать её на лист "Выводы". Сделал я это с помощью функции Find (поиск). Но у меня эта часть макроса работает очень медленно. Вопрос к Вам : Как ускорить эту часть макроса?? Т.е. во вложенном Excel после появления
MsgBox "Выполнено за " & timeGetTime - d & " милисекунд"
доработать код. Спасибо за ответ..

[kuklp]

Он у Вас еще и считает не все.

[nilem]

Юзаем зеленую стрелку.
Данные сократил - слишком большой файл.

[Hugo121]

Я универсальный код для таких задач написал:
http://www.planetaexcel.ru/forum.php?thread_id=26105
Вашу задачу на полном файле делает секунды за полторы.
Просто выделяете два столбца и запускаете по Alt+F8 код из открытого в фоне файла по ссылке.
Результат будет в новой книге.
Результат как у Николая, только общего подсчёта нет - это не универсальная задача

[nilem]

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

Я универсальный код для таких задач написал ...

Примерно также хотел сделать, но засомневался с Application.Transpose(oDict.keys). Вдруг там уникальных более 60000? Обрежет.

[Hugo121]

Да, спасибо за замечание.
Тогда нужно доделать - сперва переложить без транспонирования в массивы/массив, потом их выгрузить.
Займусь на досуге...

[Hugo121]

Убрал Transpose - сразу набираем данные в массив, который будем выгружать.
Немного изменил по мелочи для ускорения.
42000 строк с 4-мя уникальными обрабатывает за полсекунды.

Option Explicit

Sub UniqSummUniversal() 'вариант без Transpose - для больших объёмов
'Выделить диапазон, где в первом столбце - неуникальные, в последнем - суммы
Dim a(), b(), oDict As Object, i&, ii&, temp$, x&
Dim ind&
'Dim tm: tm = Timer
a = Selection.Value
ReDim b(1 To UBound(a, 1), 1 To 2)
ind = UBound(a, 2)
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = 1
For i = 1 To UBound(a)
    If Not IsEmpty(a(i, ind)) Then
        If IsNumeric(a(i, ind)) Then
        temp = Trim(a(i, 1))
            If Not oDict.Exists(temp) Then
            ii = ii + 1
            b(ii, 1) = temp: b(ii, 2) = a(i, ind)
            oDict.Add temp, CStr(ii)
            Else
            x = oDict.Item(temp)
            b(x, 2) = b(x, 2) + a(i, ind)
            End If
        End If
    End If
Next

On Error Resume Next 'если вдруг ii=0
With Workbooks.Add.Worksheets(1)
.Range("A1:B1").Resize(ii) = b
End With
On Error GoTo 0
'Debug.Print Timer - tm
End Sub

[Djeki]

Спасибо всем ответившим !! Предложенные варианты работают очень быстро..

[Miguel Sanchez]

Всем здрасте!
Может не совсем по теме, но все же... Хочется поподробней узнать о принципах работы с коллекцией и, как частного случая- со словарем. В хэлпе справка какая-то замученная. Может кто ссылками поделится?

[Hugo121]

Dictionary - это совсем не сложно!
Alex_ST постарался (описание свойств и методов объектов Dictionary и Collection) :
http://www.excelworld.ru/forum/3-313-1